diff --git a/.github/workflows/cabal.yml b/.github/workflows/cabal.yml new file mode 100644 index 00000000..7f82094b --- /dev/null +++ b/.github/workflows/cabal.yml @@ -0,0 +1,60 @@ +name: Continuous integration + +on: + push: + paths-ignore: + - 'website/*/**' + - 'README.md' + pull_request: + +jobs: + continuous-integration: + strategy: + fail-fast: false + matrix: + ghc-version: + - "8.10.7" + - "9.0.2" + - "9.2.8" + - "9.4.5" + - "9.6.4" + - "9.8.2" + - "9.10.1" + operating-system: + - "ubuntu-latest" + + runs-on: ${{ matrix.operating-system }} + + steps: + - uses: actions/checkout@v4 + + - name: Install cabal/ghc + uses: haskell-actions/setup@v2 + id: setup-haskell + with: + ghc-version: ${{ matrix.ghc-version }} + cabal-version: '3.12.1.0' + + - name: Generate freeze file + run: | + cabal configure --enable-tests --test-show-details=direct + cabal freeze --minimize-conflict-set + + - name: Cache cabal work + uses: actions/cache@v4 + with: + path: | + dist-newstyle + ${{ steps.setup-haskell.outputs.cabal-store }} + # We are using the hash of 'cabal.project.local' so that different levels + # of optimizations are cached separately + key: ${{ runner.os }}-${{ hashFiles('cabal.project', 'cabal.project.local') }}-cabal-install + + - name: Build dependencies only + run: cabal build all --only-dependencies + + - name: Build all packages + run: cabal build all + + - name: Run all tests + run: cabal test all \ No newline at end of file diff --git a/.github/workflows/distributed-process-ci.yml b/.github/workflows/distributed-process-ci.yml deleted file mode 100644 index 73154532..00000000 --- a/.github/workflows/distributed-process-ci.yml +++ /dev/null @@ -1,39 +0,0 @@ -name: distributed-process-ci -on: [push, pull_request] -jobs: - test: - runs-on: ubuntu-latest - strategy: - matrix: - ghcVersion: - [ "8.10.7" - , "9.0.2" - , "9.2.7" - , "9.4.5" - , "9.8.2" - ] - container: "fpco/stack-build-small" - steps: - - name: Check out repository code - uses: actions/checkout@v2 - - name: Cache stack dependencies - uses: actions/cache@v2 - with: - path: ${{ github.workspace }}/stack-root - key: cache-key-${{ runner.os }}-${{ hashFiles(format('stack-ghc-{0}.yaml', matrix.ghcVersion)) }} - - shell: bash - name: run tests - run: | - set -ex - chown $(whoami) "$GITHUB_WORKSPACE" - export STACK_ROOT="$GITHUB_WORKSPACE/stack-root" - export ARGS="--stack-yaml stack-ghc-${{ matrix.ghcVersion }}.yaml" - export ARG='--test-arguments' - export TEST_PACKAGE="distributed-process-tests:" - stack ${ARGS} test $ARG='--plain -t "!Flaky"' ${TEST_PACKAGE}TestCHInMemory - stack ${ARGS} test $ARG='--plain -t "!Flaky"' ${TEST_PACKAGE}TestCHInTCP - stack ${ARGS} test $ARG='--plain -t "!SpawnReconnect"' ${TEST_PACKAGE}TestClosure - stack ${ARGS} test $ARG='--plain' ${TEST_PACKAGE}TestStats - stack ${ARGS} test $ARG='--plain' ${TEST_PACKAGE}TestMxInMemory - stack ${ARGS} test $ARG='--plain' ${TEST_PACKAGE}TestMxInTCP - stack ${ARGS} test $ARG='--plain' ${TEST_PACKAGE}TestTracingInMemory diff --git a/.gitignore b/.gitignore index 6bb97f03..6cd6fcfd 100644 --- a/.gitignore +++ b/.gitignore @@ -1,6 +1,27 @@ -dist/ -dist-newstyle/ -.cabal-sandbox +dist +dist-* +cabal-dev +*.o +*.hi +*.hie +*.chi +*.chs.h +*.dyn_o +*.dyn_hi +.hpc +.hsenv +.cabal-sandbox/ cabal.sandbox.config -.stack* -stack.yaml.lock +*.prof +*.aux +*.hp +*.eventlog +.stack-work/ +cabal.project.local +cabal.project.local~ +.HTF/ +.ghc.environment.* +.*.swo +.*.swp +_site +.DS_Store diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 7a4f3ee4..8fb8a76d 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -1 +1,57 @@ -See https://github.com/haskell-distributed/cloud-haskell/blob/master/CONTRIBUTING.md. +# Cloud Haskell contributor guidelines + +## Building + +After cloning, you should be able to build all packages in this repository like so: + +``` +$ cabal build all +``` + +You can also build a specific package like so: + +``` +cabal build +``` + +You can have more control over the behavior of `cabal` by configuring, first. For example, if you want to disable optimizations for faster compilation: + +``` +$ cabal configure --disable-optimization +$ cabal build all +``` + +The allowed arguments for `cabal configure` are [documented here](https://cabal.readthedocs.io/en/stable/cabal-project-description-file.html#global-configuration-options). + +Tests for all packages can be run with: + +``` +$ cabal test all +``` + +or again, you can test a specific package `` using: + +``` +$ cabal test +``` + +### Building with specific dependencies + +Often, we want to build a package with a specific version of a dependency, for testing or debugging purposes. In this case, recall that you can always constrain cabal using the `--constraint` flag. For example, if I want to build `distributed-process-async` with `async==2.2.5`: + +``` +$ cabal build distributed-process-async --constraint="async==2.2.5" +``` + +## Contributing changes upstream + +To contribute changes, you first need a fork. First, fork the `distributed-process` repository following the [instructions here](https://docs.github.com/en/pull-requests/collaborating-with-pull-requests/working-with-forks/fork-a-repo). + +Then publish branches: + +``` +$ cabal test all # Check that everything works before proceeding. +$ git push --set-upstream +``` + +Then you can [create a pull-request](https://docs.github.com/en/pull-requests/collaborating-with-pull-requests/proposing-changes-to-your-work-with-pull-requests/creating-a-pull-request) to contribute changes back to `distributed-process`. diff --git a/cabal.project b/cabal.project new file mode 100644 index 00000000..4eeb22f6 --- /dev/null +++ b/cabal.project @@ -0,0 +1,4 @@ +packages: packages/*/**.cabal + +package distributed-process-tests + flags: +tcp \ No newline at end of file diff --git a/distributed-process-tests/CONTRIBUTING.md b/distributed-process-tests/CONTRIBUTING.md deleted file mode 100644 index 7a4f3ee4..00000000 --- a/distributed-process-tests/CONTRIBUTING.md +++ /dev/null @@ -1 +0,0 @@ -See https://github.com/haskell-distributed/cloud-haskell/blob/master/CONTRIBUTING.md. diff --git a/distributed-process-tests/README.md b/distributed-process-tests/README.md deleted file mode 100644 index b625c591..00000000 --- a/distributed-process-tests/README.md +++ /dev/null @@ -1,13 +0,0 @@ -# distributed-process-tests -[![Release](https://img.shields.io/hackage/v/distributed-process-tests.svg)](https://hackage.haskell.org/package/distributed-process-tests) - -See http://haskell-distributed.github.com for documentation, user guides, -tutorials and assistance. - -## Getting Help / Raising Issues - -Please visit the [bug tracker](https://github.com/haskell-distributed/distributed-process-tests/issues) to submit issues. You can contact the distributed-haskell@googlegroups.com mailing list for help and comments. - -## License - -This package is made available under a 3-clause BSD-style license. diff --git a/distributed-process-tests/Setup.hs b/distributed-process-tests/Setup.hs deleted file mode 100644 index 9a994af6..00000000 --- a/distributed-process-tests/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/packages/distributed-process-async/CHANGELOG.md b/packages/distributed-process-async/CHANGELOG.md new file mode 100644 index 00000000..13cc26ff --- /dev/null +++ b/packages/distributed-process-async/CHANGELOG.md @@ -0,0 +1,21 @@ +2024-03-25 David Simmons-Duffin 0.2.7 + +* Bump dependencies to build with ghc-9.8. + +2018-06-14 Alexander Vershilov 0.2.6 + +* Update dependency bounds +* Export all documented functions (Issue #9) + +2016-02-16 Facundo Domínguez 0.2.3 + +* Update dependency bounds. + +# HEAD + +* Added initial GenServer module +* Added Timer Module +* Moved time functions into Time.hs +* Added Async API +* Added GenProcess API (subsumes lower level GenServer API) + diff --git a/packages/distributed-process-async/LICENCE b/packages/distributed-process-async/LICENCE new file mode 100644 index 00000000..f7a8c56f --- /dev/null +++ b/packages/distributed-process-async/LICENCE @@ -0,0 +1,30 @@ +Copyright Tim Watson, 2012-2013. + +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. diff --git a/packages/distributed-process-async/NOTES b/packages/distributed-process-async/NOTES new file mode 100644 index 00000000..7839de4e --- /dev/null +++ b/packages/distributed-process-async/NOTES @@ -0,0 +1,22 @@ +MAJOR TODOs (in no particular order) + +- implement Observable for Mailbox +- implement PCopy / pcopy :: PCopy a -> Process () and precv :: Process (Maybe (PCopy a)) +- provide InputChannel for PCopy data, i.e.: + +data InputChannel a = ReadChan (ReceivePort a) | ReadSTM (STM a) + +read (ReadChan rp) = expectChan rp +read (ReadSTM stm) = liftIO $ atomically stm + +offer + +- implement RoundRobinRouter, ContentBasedRouter +- finish off ResourcePool +- double check we're using NFSerializable where possible/necessary + +- implement LocalRegistry (?) +- possibly rationalise Registry with LocalRegistry (?) +- Health checks for services +- Service Monitoring + diff --git a/packages/distributed-process-async/distributed-process-async.cabal b/packages/distributed-process-async/distributed-process-async.cabal new file mode 100644 index 00000000..0e79c971 --- /dev/null +++ b/packages/distributed-process-async/distributed-process-async.cabal @@ -0,0 +1,87 @@ +cabal-version: 3.0 +name: distributed-process-async +version: 0.2.7 +build-type: Simple +license: BSD-3-Clause +license-file: LICENCE +stability: experimental +Copyright: Tim Watson 2012 - 2016 +Author: Tim Watson +maintainer: The Distributed Haskell team +Homepage: http://github.com/haskell-distributed/distributed-process-async +Bug-Reports: http://github.com/haskell-distributed/distributed-process-async/issues +synopsis: Cloud Haskell Async API +description: This package provides a higher-level interface over Processes, in which an Async a is a + concurrent, possibly distributed Process that will eventually deliver a value of type a. + The package provides ways to create Async computations, wait for their results, and cancel them. +category: Control +tested-with: GHC==8.10.7 GHC==9.0.2 GHC==9.2.8 GHC==9.4.5 GHC==9.6.4 GHC==9.8.2 GHC==9.10.1 + +source-repository head + type: git + location: https://github.com/haskell-distributed/distributed-process-async + +common warnings + ghc-options: -Wall + -Wcompat + -Widentities + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wredundant-constraints + -fhide-source-paths + -Wpartial-fields + +library + import: warnings + build-depends: + base >= 4.14 && < 5, + data-accessor >= 0.2.2.3, + distributed-process >= 0.6.1 && < 0.8, + exceptions >= 0.10 && < 1.0, + binary >= 0.8 && < 0.9, + deepseq >= 1.4 && < 1.6, + mtl, + containers >= 0.6 && < 0.8, + hashable >= 1.2.0.5 && < 1.6, + unordered-containers >= 0.2.3.0 && < 0.3, + fingertree < 0.2, + stm >= 2.4 && < 2.6, + time >= 1.9, + transformers + default-extensions: CPP + InstanceSigs + hs-source-dirs: src + default-language: Haskell2010 + exposed-modules: + Control.Distributed.Process.Async + other-modules: + Control.Distributed.Process.Async.Internal.Types + +test-suite AsyncTests + import: warnings + type: exitcode-stdio-1.0 + x-uses-tf: true + build-depends: + base >= 4.14 && < 5, + ansi-terminal >= 0.5 && < 0.9, + distributed-process, + distributed-process-async, + distributed-process-systest >= 0.2.0, + exceptions >= 0.10 && < 1.0, + network >= 2.5 && < 3.3, + network-transport >= 0.4 && < 0.6, + network-transport-tcp >= 0.6 && < 0.9, + binary >= 0.8 && < 0.9, + deepseq >= 1.4 && < 1.6, + -- HUnit >= 1.2 && < 2, + stm >= 2.3 && < 2.6, + test-framework >= 0.6 && < 0.9, + test-framework-hunit, + rematch >= 0.2.0.0, + transformers + hs-source-dirs: + tests + default-language: Haskell2010 + ghc-options: -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind + default-extensions: CPP + main-is: TestAsync.hs diff --git a/packages/distributed-process-async/profiling/configure.sh b/packages/distributed-process-async/profiling/configure.sh new file mode 100755 index 00000000..183b0912 --- /dev/null +++ b/packages/distributed-process-async/profiling/configure.sh @@ -0,0 +1,3 @@ +#!/bin/sh +cabal clean +cabal configure --enable-library-profiling --enable-executable-profiling diff --git a/packages/distributed-process-async/profiling/run.sh b/packages/distributed-process-async/profiling/run.sh new file mode 100755 index 00000000..04f5eeb1 --- /dev/null +++ b/packages/distributed-process-async/profiling/run.sh @@ -0,0 +1,16 @@ +#!/bin/sh +PROG=dtp +VIEW=open +FLAGS= +DIST_DIR=./dist + + +cabal build +mkdir -p ${DIST_DIR}/profiling +( + cd ${DIST_DIR}/profiling + ../build/${PROG}/${PROG} ${FLAGS} +RTS -p -hc -s${PROG}.summary + hp2ps ${PROG}.hp +) +${VIEW} ${DIST_DIR}/profiling/${PROG}.ps +cat ${DIST_DIR}/profiling/${PROG}.summary \ No newline at end of file diff --git a/packages/distributed-process-async/src/Control/Distributed/Process/Async.hs b/packages/distributed-process-async/src/Control/Distributed/Process/Async.hs new file mode 100644 index 00000000..e013d381 --- /dev/null +++ b/packages/distributed-process-async/src/Control/Distributed/Process/Async.hs @@ -0,0 +1,327 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Control.Distributed.Process.Async +-- Copyright : (c) Tim Watson 2012 +-- License : BSD3 (see the file LICENSE) +-- +-- Maintainer : Tim Watson +-- Stability : experimental +-- Portability : non-portable (requires concurrency) +-- +-- This API provides a means for spawning asynchronous operations, waiting +-- for their results, cancelling them and various other utilities. +-- Asynchronous operations can be executed on remote nodes. +-- +-- [Asynchronous Operations] +-- +-- There is an implicit contract for async workers; Workers must exit +-- normally (i.e., should not call the 'exit', 'die' or 'terminate' +-- Cloud Haskell primitives), otherwise the 'AsyncResult' will end up being +-- @AsyncFailed DiedException@ instead of containing the result. +-- +-- Portions of this file are derived from the @Control.Concurrent.Async@ +-- module, from the @async@ package written by Simon Marlow. +----------------------------------------------------------------------------- + +module Control.Distributed.Process.Async + ( -- * Exported types + AsyncRef + , AsyncTask(..) + , Async + , AsyncResult(..) + -- * Spawning asynchronous operations + , async + , asyncLinked + , task + , remoteTask + , monitorAsync + , asyncWorker + -- * Cancelling asynchronous operations + , cancel + , cancelWait + , cancelWith + , cancelKill + -- * Querying for results + , poll + , check + , wait + , waitAny + -- * Waiting with timeouts + , waitAnyTimeout + , waitTimeout + , waitCancelTimeout + , waitCheckTimeout + -- * STM versions + , pollSTM + , waitSTM + , waitAnySTM + , waitAnyCancel + , waitEither + , waitEither_ + , waitBoth + ) where + +import Control.Applicative +import Control.Concurrent.STM hiding (check) +import Control.Distributed.Process hiding (catch, finally) +import Control.Distributed.Process.Serializable +import Control.Distributed.Process.Async.Internal.Types +import Control.Monad +import Control.Monad.Catch (finally) +import Data.Maybe + ( fromMaybe + ) + +import System.Timeout (timeout) +import Prelude + +-- | Wraps a regular @Process a@ as an 'AsyncTask'. +task :: Process a -> AsyncTask a +task = AsyncTask + +-- | Wraps the components required and builds a remote 'AsyncTask'. +remoteTask :: Static (SerializableDict a) + -> NodeId + -> Closure (Process a) + -> AsyncTask a +remoteTask = AsyncRemoteTask + +-- | Given an 'Async' handle, monitor the worker process. +monitorAsync :: Async a -> Process MonitorRef +monitorAsync = monitor . _asyncWorker + +-- | Spawns an asynchronous action and returns a handle to it, +-- which can be used to obtain its status and/or result or interact +-- with it (using the API exposed by this module). +-- +async :: (Serializable a) => AsyncTask a -> Process (Async a) +async = asyncDo False + +-- | Provides the pid of the worker process performing the async operation. +asyncWorker :: Async a -> ProcessId +asyncWorker = _asyncWorker + +-- | This is a useful variant of 'async' that ensures an @Async@ task is +-- never left running unintentionally. We ensure that if the caller's process +-- exits, that the worker is killed. +-- +-- There is currently a contract for async workers, that they should +-- exit normally (i.e., they should not call the @exit@ or @kill@ with their own +-- 'ProcessId' nor use the @terminate@ primitive to cease functining), otherwise +-- the 'AsyncResult' will end up being @AsyncFailed DiedException@ instead of +-- containing the desired result. +-- +asyncLinked :: (Serializable a) => AsyncTask a -> Process (Async a) +asyncLinked = asyncDo True + +-- private API +asyncDo :: (Serializable a) => Bool -> AsyncTask a -> Process (Async a) +asyncDo shouldLink (AsyncRemoteTask d n c) = + asyncDo shouldLink $ AsyncTask $ call d n c +asyncDo shouldLink (AsyncTask proc) = do + root <- getSelfPid + result <- liftIO newEmptyTMVarIO + sigStart <- liftIO newEmptyTMVarIO + (sp, rp) <- newChan + + -- listener/response proxy + insulator <- spawnLocal $ do + worker <- spawnLocal $ do + liftIO $ atomically $ takeTMVar sigStart + r <- proc + void $ liftIO $ atomically $ putTMVar result (AsyncDone r) + + sendChan sp worker -- let the parent process know the worker pid + + wref <- monitor worker + rref <- if shouldLink then fmap Just (monitor root) else return Nothing + finally (pollUntilExit worker result) + (unmonitor wref >> + return (maybe (return ()) unmonitor rref)) + + workerPid <- receiveChan rp + liftIO $ atomically $ putTMVar sigStart () + + return Async { _asyncWorker = workerPid + , _asyncMonitor = insulator + , _asyncWait = readTMVar result + } + + where + pollUntilExit :: (Serializable a) + => ProcessId + -> TMVar (AsyncResult a) + -> Process () + pollUntilExit wpid result' = do + r <- receiveWait [ + match (\c@CancelWait -> kill wpid "cancel" >> return (Left c)) + , match (\(ProcessMonitorNotification _ pid' r) -> + return (Right (pid', r))) + ] + case r of + Left CancelWait + -> liftIO $ atomically $ putTMVar result' AsyncCancelled + Right (fpid, d) + | fpid == wpid -> case d of + DiedNormal -> return () + _ -> liftIO $ atomically $ void $ + tryPutTMVar result' (AsyncFailed d) + | otherwise -> do + kill wpid "linkFailed" + receiveWait + [ matchIf (\(ProcessMonitorNotification _ pid' _) -> + pid' == wpid + ) $ \_ -> return () + ] + liftIO $ atomically $ void $ + tryPutTMVar result' (AsyncLinkFailed d) + +-- | Check whether an 'Async' has completed yet. +poll :: (Serializable a) => Async a -> Process (AsyncResult a) +poll hAsync = do + r <- liftIO $ atomically $ pollSTM hAsync + return $ fromMaybe AsyncPending r + +-- | Like 'poll' but returns 'Nothing' if @(poll hAsync) == AsyncPending@. +check :: (Serializable a) => Async a -> Process (Maybe (AsyncResult a)) +check hAsync = poll hAsync >>= \r -> case r of + AsyncPending -> return Nothing + ar -> return (Just ar) + +-- | Wait for an asynchronous operation to complete or timeout. +waitCheckTimeout :: (Serializable a) => + Int -> Async a -> Process (AsyncResult a) +waitCheckTimeout t hAsync = + fmap (fromMaybe AsyncPending) (waitTimeout t hAsync) + +-- | Wait for an asynchronous action to complete, and return its +-- value. The result (which can include failure and/or cancellation) is +-- encoded by the 'AsyncResult' type. +-- +-- @wait = liftIO . atomically . waitSTM@ +-- +{-# INLINE wait #-} +wait :: Async a -> Process (AsyncResult a) +wait = liftIO . atomically . waitSTM + +-- | Wait for an asynchronous operation to complete or timeout. +waitTimeout :: (Serializable a) => + Int -> Async a -> Process (Maybe (AsyncResult a)) +waitTimeout t hAsync = + liftIO $ timeout t $ atomically $ waitSTM hAsync + +-- | Wait for an asynchronous operation to complete or timeout. +-- If it times out, then 'cancelWait' the async handle. +-- +waitCancelTimeout :: (Serializable a) + => Int + -> Async a + -> Process (AsyncResult a) +waitCancelTimeout t hAsync = do + r <- waitTimeout t hAsync + case r of + Nothing -> cancelWait hAsync + Just ar -> return ar + +-- | Wait for any of the supplied @Async@s to complete. If multiple +-- 'Async's complete, then the value returned corresponds to the first +-- completed 'Async' in the list. +-- +-- NB: Unlike @AsyncChan@, 'Async' does not discard its 'AsyncResult' once +-- read, therefore the semantics of this function are different to the +-- former. Specifically, if @asyncs = [a1, a2, a3]@ and @(AsyncDone _) = a1@ +-- then the remaining @a2, a3@ will never be returned by 'waitAny'. +-- +waitAny :: (Serializable a) + => [Async a] + -> Process (Async a, AsyncResult a) +waitAny asyncs = liftIO $ waitAnySTM asyncs + +-- | Like 'waitAny', but also cancels the other asynchronous +-- operations as soon as one has completed. +-- +waitAnyCancel :: (Serializable a) + => [Async a] -> Process (Async a, AsyncResult a) +waitAnyCancel asyncs = + waitAny asyncs `finally` mapM_ cancel asyncs + +-- | Wait for the first of two @Async@s to finish. +-- +waitEither :: Async a + -> Async b + -> Process (Either (AsyncResult a) (AsyncResult b)) +waitEither left right = + liftIO $ atomically $ + (Left <$> waitSTM left) + `orElse` + (Right <$> waitSTM right) + +-- | Like 'waitEither', but the result is ignored. +-- +waitEither_ :: Async a -> Async b -> Process () +waitEither_ left right = + liftIO $ atomically $ + (void $ waitSTM left) + `orElse` + (void $ waitSTM right) + +-- | Waits for both @Async@s to finish. +-- +waitBoth :: Async a + -> Async b + -> Process (AsyncResult a, AsyncResult b) +waitBoth left right = + liftIO $ atomically $ do + a <- waitSTM left + `orElse` + (waitSTM right >> retry) + b <- waitSTM right + return (a,b) + +-- | Like 'waitAny' but times out after the specified delay. +waitAnyTimeout :: (Serializable a) + => Int + -> [Async a] + -> Process (Maybe (AsyncResult a)) +waitAnyTimeout delay asyncs = + liftIO $ timeout delay $ do + r <- waitAnySTM asyncs + return $ snd r + +-- | Cancel an asynchronous operation. +cancel :: Async a -> Process () +cancel (Async _ g _) = send g CancelWait + +-- | Cancel an asynchronous operation and wait for the cancellation to complete. +cancelWait :: (Serializable a) => Async a -> Process (AsyncResult a) +cancelWait hAsync = cancel hAsync >> wait hAsync + +-- | Cancel an asynchronous operation immediately. +cancelWith :: (Serializable b) => b -> Async a -> Process () +cancelWith reason hAsync = exit (_asyncWorker hAsync) reason + +-- | Like 'cancelWith' but sends a @kill@ instruction instead of an exit. +cancelKill :: String -> Async a -> Process () +cancelKill reason hAsync = kill (_asyncWorker hAsync) reason + +-------------------------------------------------------------------------------- +-- STM Specific API -- +-------------------------------------------------------------------------------- + +-- | STM version of 'waitAny'. +waitAnySTM :: [Async a] -> IO (Async a, AsyncResult a) +waitAnySTM asyncs = + atomically $ + foldr orElse retry $ + map (\a -> do r <- waitSTM a; return (a, r)) asyncs + +-- | A version of 'wait' that can be used inside an STM transaction. +-- +waitSTM :: Async a -> STM (AsyncResult a) +waitSTM (Async _ _ w) = w + +-- | A version of 'poll' that can be used inside an STM transaction. +-- +{-# INLINE pollSTM #-} +pollSTM :: Async a -> STM (Maybe (AsyncResult a)) +pollSTM (Async _ _ w) = (Just <$> w) `orElse` return Nothing diff --git a/packages/distributed-process-async/src/Control/Distributed/Process/Async/Internal/Types.hs b/packages/distributed-process-async/src/Control/Distributed/Process/Async/Internal/Types.hs new file mode 100644 index 00000000..5887ab46 --- /dev/null +++ b/packages/distributed-process-async/src/Control/Distributed/Process/Async/Internal/Types.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveFunctor #-} + +-- | shared, internal types for the Async package +module Control.Distributed.Process.Async.Internal.Types + ( -- * Exported types + Async(..) + , AsyncRef + , AsyncTask(..) + , AsyncResult(..) + , CancelWait(..) + ) where + +import Control.Concurrent.STM +import Control.Distributed.Process +import Control.Distributed.Process.Serializable + ( Serializable + , SerializableDict + ) +import Data.Binary +import Data.Typeable (Typeable) + +import GHC.Generics + +-- | A reference to an asynchronous action +type AsyncRef = ProcessId + +-- | An handle for an asynchronous action spawned by 'async'. +-- Asynchronous operations are run in a separate process, and +-- operations are provided for waiting for asynchronous actions to +-- complete and obtaining their results (see e.g. 'wait'). +-- +-- Handles of this type cannot cross remote boundaries, nor are they +-- @Serializable@. +data Async a = Async { + _asyncWorker :: AsyncRef + , _asyncMonitor :: AsyncRef + , _asyncWait :: STM (AsyncResult a) + } deriving (Functor) + +instance Eq (Async a) where + Async a b _ == Async c d _ = a == c && b == d + +instance Ord (Async a) where + compare (Async a b _) (Async c d _) = a `compare` c <> b `compare` d + +-- | A task to be performed asynchronously. +data AsyncTask a = + AsyncTask { + asyncTask :: Process a -- ^ the task to be performed + } + | AsyncRemoteTask { + asyncTaskDict :: Static (SerializableDict a) + -- ^ the serializable dict required to spawn a remote process + , asyncTaskNode :: NodeId + -- ^ the node on which to spawn the asynchronous task + , asyncTaskProc :: Closure (Process a) + -- ^ the task to be performed, wrapped in a closure environment + } + +-- | Represents the result of an asynchronous action, which can be in one of +-- several states at any given time. +data AsyncResult a = + AsyncDone a -- ^ a completed action and its result + | AsyncFailed DiedReason -- ^ a failed action and the failure reason + | AsyncLinkFailed DiedReason -- ^ a link failure and the reason + | AsyncCancelled -- ^ a cancelled action + | AsyncPending -- ^ a pending action (that is still running) + deriving (Typeable, Generic, Functor) + + +instance Serializable a => Binary (AsyncResult a) where + +deriving instance Eq a => Eq (AsyncResult a) +deriving instance Show a => Show (AsyncResult a) + +-- | A message to cancel Async operations +data CancelWait = CancelWait + deriving (Typeable, Generic) +instance Binary CancelWait diff --git a/packages/distributed-process-async/test-report.hs b/packages/distributed-process-async/test-report.hs new file mode 100755 index 00000000..523ecf79 --- /dev/null +++ b/packages/distributed-process-async/test-report.hs @@ -0,0 +1,10 @@ +#! /bin/sh + +HPC_DIR=dist/hpc + +cabal-dev clean +cabal-dev configure --enable-tests --enable-library-coverage +cabal-dev build +cabal-dev test + +open ${HPC_DIR}/html/*/hpc-index.html diff --git a/packages/distributed-process-async/tests/TestAsync.hs b/packages/distributed-process-async/tests/TestAsync.hs new file mode 100644 index 00000000..a620c8d9 --- /dev/null +++ b/packages/distributed-process-async/tests/TestAsync.hs @@ -0,0 +1,227 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +import Control.Concurrent.MVar +import Control.Distributed.Process +import Control.Distributed.Process.Closure +import Control.Distributed.Process.Node +import Control.Distributed.Process.Serializable() +import Control.Distributed.Process.Async +import Control.Distributed.Process.SysTest.Utils +import Control.Monad (replicateM_) +import Data.Binary() +import Data.Typeable() +import Network.Transport.TCP +import qualified Network.Transport as NT + +import Test.Framework (Test, testGroup, defaultMain) +import Test.Framework.Providers.HUnit (testCase) + +testAsyncPoll :: TestResult (AsyncResult ()) -> Process () +testAsyncPoll result = do + hAsync <- async $ task $ do "go" <- expect; say "running" >> return () + ar <- poll hAsync + case ar of + AsyncPending -> + send (asyncWorker hAsync) "go" >> wait hAsync >>= stash result + _ -> stash result ar >> return () + +-- Tests that an async action can be canceled. +testAsyncCancel :: TestResult (AsyncResult ()) -> Process () +testAsyncCancel result = do + hAsync <- async $ task (expect :: Process ()) + + p <- poll hAsync + case p of + AsyncPending -> cancel hAsync >> wait hAsync >>= stash result + _ -> say (show p) >> stash result p + +-- Tests that cancelWait completes when the worker dies. +testAsyncCancelWait :: TestResult (Maybe (AsyncResult ())) -> Process () +testAsyncCancelWait result = do + hAsync <- async $ task (expect :: Process ()) + + AsyncPending <- poll hAsync + cancelWait hAsync >>= stash result . Just + +-- Tests that waitTimeout completes when the timeout expires. +testAsyncWaitTimeout :: TestResult (Maybe (AsyncResult ())) -> Process () +testAsyncWaitTimeout result = do + hAsync <- async $ task (expect :: Process ()) + waitTimeout 100000 hAsync >>= stash result + cancelWait hAsync >> return () + +-- Tests that an async action can be awaited to completion even with a timeout. +testAsyncWaitTimeoutCompletes :: TestResult (Maybe (AsyncResult ())) + -> Process () +testAsyncWaitTimeoutCompletes result = do + hAsync <- async $ task (expect :: Process ()) + r <- waitTimeout 100000 hAsync + case r of + Nothing -> send (asyncWorker hAsync) () + >> wait hAsync >>= stash result . Just + Just _ -> cancelWait hAsync >> stash result Nothing + +-- Tests that a linked async action dies when the parent dies. +testAsyncLinked :: TestResult Bool -> Process () +testAsyncLinked result = do + mv :: MVar (Async ()) <- liftIO newEmptyMVar + pid <- spawnLocal $ do + -- NB: async == asyncLinked for AsyncChan + h <- asyncLinked $ task (expect :: Process ()) + stash mv h + expect + + hAsync <- liftIO $ takeMVar mv + + mref <- monitorAsync hAsync + exit pid "stop" + + _ <- receiveWait [ + matchIf (\(ProcessMonitorNotification mref' _ _) -> mref == mref') + (\_ -> return ()) + ] + + -- since the initial caller died and we used 'asyncLinked', the async should + -- pick up on the exit signal and set the result accordingly. trying to match + -- on 'DiedException String' is pointless though, as the *string* is highly + -- context dependent. + r <- wait hAsync + case r of + AsyncLinkFailed _ -> stash result True + _ -> stash result False + +-- Tests that waitAny returns when any of the actions complete. +testAsyncWaitAny :: TestResult [AsyncResult String] -> Process () +testAsyncWaitAny result = do + p1 <- async $ task expect + p2 <- async $ task expect + p3 <- async $ task expect + send (asyncWorker p3) "c" + r1 <- waitAny [p1, p2, p3] + + send (asyncWorker p1) "a" + send (asyncWorker p2) "b" + ref1 <- monitorAsync p1 + ref2 <- monitorAsync p2 + replicateM_ 2 $ receiveWait + [ matchIf (\(ProcessMonitorNotification ref _ _) -> elem ref [ref1, ref2]) + $ \_ -> return () + ] + + r2 <- waitAny [p2, p3] + r3 <- waitAny [p1, p2, p3] + + stash result $ map snd [r1, r2, r3] + +-- Tests that waitAnyTimeout returns when the timeout expires. +testAsyncWaitAnyTimeout :: TestResult (Maybe (AsyncResult String)) -> Process () +testAsyncWaitAnyTimeout result = do + p1 <- asyncLinked $ task expect + p2 <- asyncLinked $ task expect + p3 <- asyncLinked $ task expect + waitAnyTimeout 100000 [p1, p2, p3] >>= stash result + +-- Tests that cancelWith terminates the worker with the given reason. +testAsyncCancelWith :: TestResult Bool -> Process () +testAsyncCancelWith result = do + p1 <- async $ task $ do { s :: String <- expect; return s } + cancelWith "foo" p1 + AsyncFailed (DiedException _) <- wait p1 + stash result True + +-- Tests that waitCancelTimeout returns when the timeout expires. +testAsyncWaitCancelTimeout :: TestResult (AsyncResult ()) -> Process () +testAsyncWaitCancelTimeout result = do + p1 <- async $ task expect + waitCancelTimeout 1000000 p1 >>= stash result + +remotableDecl [ + [d| fib :: (NodeId,Int) -> Process Integer ; + fib (_,0) = return 0 + fib (_,1) = return 1 + fib (myNode,n) = do + let tsk = remoteTask ($(functionTDict 'fib)) myNode ($(mkClosure 'fib) (myNode,n-2)) + future <- async tsk + y <- fib (myNode,n-1) + (AsyncDone z) <- wait future + return $ y + z + |] + ] + +-- Tests that wait returns when remote actions complete. +testAsyncRecursive :: TestResult Integer -> Process () +testAsyncRecursive result = do + myNode <- getSelfNode + fib (myNode,6) >>= stash result + +tests :: LocalNode -> [Test] +tests localNode = [ + testGroup "Handling async results with STM" [ + testCase "testAsyncCancel" + (delayedAssertion + "expected async task to have been cancelled" + localNode (AsyncCancelled) testAsyncCancel) + , testCase "testAsyncPoll" + (delayedAssertion + "expected poll to return a valid AsyncResult" + localNode (AsyncDone ()) testAsyncPoll) + , testCase "testAsyncCancelWait" + (delayedAssertion + "expected cancelWait to complete some time" + localNode (Just AsyncCancelled) testAsyncCancelWait) + , testCase "testAsyncWaitTimeout" + (delayedAssertion + "expected waitTimeout to return Nothing when it times out" + localNode (Nothing) testAsyncWaitTimeout) + , testCase "testAsyncWaitTimeoutCompletes" + (delayedAssertion + "expected waitTimeout to return a value" + localNode (Just (AsyncDone ())) testAsyncWaitTimeoutCompletes) + , testCase "testAsyncLinked" + (delayedAssertion + "expected linked process to die with originator" + localNode True testAsyncLinked) + , testCase "testAsyncWaitAny" + (delayedAssertion + "expected waitAny to pick the first result each time" + localNode [AsyncDone "c", + AsyncDone "b", + AsyncDone "a"] testAsyncWaitAny) + , testCase "testAsyncWaitAnyTimeout" + (delayedAssertion + "expected waitAnyTimeout to handle pending results properly" + localNode Nothing testAsyncWaitAnyTimeout) + , testCase "testAsyncCancelWith" + (delayedAssertion + "expected the worker to have been killed with the given signal" + localNode True testAsyncCancelWith) + , testCase "testAsyncRecursive" + (delayedAssertion + "expected Fibonacci 6 to be evaluated, and value of 8 returned" + localNode 8 testAsyncRecursive) + , testCase "testAsyncWaitCancelTimeout" + (delayedAssertion + "expected waitCancelTimeout to return a value" + localNode AsyncCancelled testAsyncWaitCancelTimeout) + ] + ] + +asyncStmTests :: NT.Transport -> IO [Test] +asyncStmTests transport = do + localNode <- newLocalNode transport $ __remoteTableDecl initRemoteTable + let testData = tests localNode + return testData + +-- | Given a @builder@ function, make and run a test suite on a single transport +testMain :: (NT.Transport -> IO [Test]) -> IO () +testMain builder = do + Right (transport, _) <- createTransportExposeInternals (defaultTCPAddr "127.0.0.1" "0") defaultTCPParameters + testData <- builder transport + defaultMain testData + +main :: IO () +main = testMain $ asyncStmTests diff --git a/packages/distributed-process-client-server/CHANGELOG.md b/packages/distributed-process-client-server/CHANGELOG.md new file mode 100644 index 00000000..b174d9a9 --- /dev/null +++ b/packages/distributed-process-client-server/CHANGELOG.md @@ -0,0 +1,65 @@ +# Change Log + +## [v0.2.5.1](https://github.com/haskell-distributed/distributed-process-client-server/tree/v0.2.5.1) (2018-06-14) +[Full Changelog](https://github.com/haskell-distributed/distributed-process-client-server/compare/v0.2.3...v0.2.5.1) + +* Update version bounds. +* Support exceptions-0.10. + + +## [v0.2.3](https://github.com/haskell-distributed/distributed-process-client-server/tree/v0.2.3) (2017-03-28) +[Full Changelog](https://github.com/haskell-distributed/distributed-process-client-server/compare/v0.2.2...v0.2.3) + +## [v0.2.2](https://github.com/haskell-distributed/distributed-process-client-server/tree/v0.2.2) (2017-03-27) +[Full Changelog](https://github.com/haskell-distributed/distributed-process-client-server/compare/v0.2.1...v0.2.2) + +## [v0.2.1](https://github.com/haskell-distributed/distributed-process-client-server/tree/v0.2.1) (2017-03-22) +[Full Changelog](https://github.com/haskell-distributed/distributed-process-client-server/compare/v0.2.0...v0.2.1) + +**Merged pull requests:** + +- Implement ProcessBecome [\#18](https://github.com/haskell-distributed/distributed-process-client-server/pull/18) ([hyperthunk](https://github.com/hyperthunk)) +- Safe Handler Execution [\#17](https://github.com/haskell-distributed/distributed-process-client-server/pull/17) ([hyperthunk](https://github.com/hyperthunk)) + +## [v0.2.0](https://github.com/haskell-distributed/distributed-process-client-server/tree/v0.2.0) (2017-03-13) +[Full Changelog](https://github.com/haskell-distributed/distributed-process-client-server/compare/v0.1.3.2...v0.2.0) + +**Closed issues:** + +- Read external input vectors in the prioritised mailbox drain loop [\#15](https://github.com/haskell-distributed/distributed-process-client-server/issues/15) +- Compiler should enforce rules for prioritised processes [\#13](https://github.com/haskell-distributed/distributed-process-client-server/issues/13) +- Prioritised process mailbox handling can block indefinitely [\#12](https://github.com/haskell-distributed/distributed-process-client-server/issues/12) +- `handleExternal` support [\#9](https://github.com/haskell-distributed/distributed-process-client-server/issues/9) +- `safeCall` and `tryCall` can fail if `resolve` throws [\#8](https://github.com/haskell-distributed/distributed-process-client-server/issues/8) +- Someone on IRC claims we are leaking file descriptors [\#7](https://github.com/haskell-distributed/distributed-process-client-server/issues/7) +- Support GHC 8 [\#5](https://github.com/haskell-distributed/distributed-process-client-server/issues/5) + +**Merged pull requests:** + +- Re-implement Prioritised Managed Processes [\#16](https://github.com/haskell-distributed/distributed-process-client-server/pull/16) ([hyperthunk](https://github.com/hyperthunk)) +- Update bounds & stackify [\#11](https://github.com/haskell-distributed/distributed-process-client-server/pull/11) ([hyperthunk](https://github.com/hyperthunk)) +- Handle arbitrary STM actions [\#10](https://github.com/haskell-distributed/distributed-process-client-server/pull/10) ([hyperthunk](https://github.com/hyperthunk)) +- Bump upper bounds on time and binary [\#6](https://github.com/haskell-distributed/distributed-process-client-server/pull/6) ([3noch](https://github.com/3noch)) +- make adjustments for GHC 8 support [\#4](https://github.com/haskell-distributed/distributed-process-client-server/pull/4) ([agentm](https://github.com/agentm)) +- Stick state argument to request and unify types across the handlers. [\#3](https://github.com/haskell-distributed/distributed-process-client-server/pull/3) ([wiz](https://github.com/wiz)) + +## [v0.1.3.2](https://github.com/haskell-distributed/distributed-process-client-server/tree/v0.1.3.2) (2016-02-16) +[Full Changelog](https://github.com/haskell-distributed/distributed-process-client-server/compare/v0.1.3.1...v0.1.3.2) + +## [v0.1.3.1](https://github.com/haskell-distributed/distributed-process-client-server/tree/v0.1.3.1) (2015-09-29) +[Full Changelog](https://github.com/haskell-distributed/distributed-process-client-server/compare/v0.1.2...v0.1.3.1) + +**Merged pull requests:** + +- Add compatibility with ghc-7.10 [\#1](https://github.com/haskell-distributed/distributed-process-client-server/pull/1) ([qnikst](https://github.com/qnikst)) + +## [v0.1.2](https://github.com/haskell-distributed/distributed-process-client-server/tree/v0.1.2) (2014-12-25) +[Full Changelog](https://github.com/haskell-distributed/distributed-process-client-server/compare/v0.1.1...v0.1.2) + +## [v0.1.1](https://github.com/haskell-distributed/distributed-process-client-server/tree/v0.1.1) (2014-12-17) +[Full Changelog](https://github.com/haskell-distributed/distributed-process-client-server/compare/v0.1.0...v0.1.1) + +## [v0.1.0](https://github.com/haskell-distributed/distributed-process-client-server/tree/v0.1.0) (2014-05-30) + + +\* *This Change Log was automatically generated by [github_changelog_generator](https://github.com/skywinder/Github-Changelog-Generator)* diff --git a/packages/distributed-process-client-server/LICENCE b/packages/distributed-process-client-server/LICENCE new file mode 100644 index 00000000..f7a8c56f --- /dev/null +++ b/packages/distributed-process-client-server/LICENCE @@ -0,0 +1,30 @@ +Copyright Tim Watson, 2012-2013. + +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. diff --git a/packages/distributed-process-client-server/NOTES b/packages/distributed-process-client-server/NOTES new file mode 100644 index 00000000..7839de4e --- /dev/null +++ b/packages/distributed-process-client-server/NOTES @@ -0,0 +1,22 @@ +MAJOR TODOs (in no particular order) + +- implement Observable for Mailbox +- implement PCopy / pcopy :: PCopy a -> Process () and precv :: Process (Maybe (PCopy a)) +- provide InputChannel for PCopy data, i.e.: + +data InputChannel a = ReadChan (ReceivePort a) | ReadSTM (STM a) + +read (ReadChan rp) = expectChan rp +read (ReadSTM stm) = liftIO $ atomically stm + +offer + +- implement RoundRobinRouter, ContentBasedRouter +- finish off ResourcePool +- double check we're using NFSerializable where possible/necessary + +- implement LocalRegistry (?) +- possibly rationalise Registry with LocalRegistry (?) +- Health checks for services +- Service Monitoring + diff --git a/packages/distributed-process-client-server/benchmarks/dtp-benchmarks.cabal b/packages/distributed-process-client-server/benchmarks/dtp-benchmarks.cabal new file mode 100644 index 00000000..57a6f6bd --- /dev/null +++ b/packages/distributed-process-client-server/benchmarks/dtp-benchmarks.cabal @@ -0,0 +1,15 @@ +name: dtp-benchmarks +version: 0 +build-type: Simple + +cabal-version: >=1.8 + +executable dtp-benchmark + main-is: CallServer.hs + ghc-options: -Wall -O2 + build-depends: + base, + bytestring, + criterion, + distributed-process-platform + diff --git a/packages/distributed-process-client-server/benchmarks/src/CounterServer.hs b/packages/distributed-process-client-server/benchmarks/src/CounterServer.hs new file mode 100644 index 00000000..2ddb1979 --- /dev/null +++ b/packages/distributed-process-client-server/benchmarks/src/CounterServer.hs @@ -0,0 +1,17 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +import Blaze.ByteString.Builder (toLazyByteString) +import Blaze.ByteString.Builder.Char.Utf8 (fromString) +import Control.DeepSeq (NFData(rnf)) +import Criterion.Main +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy.Internal as BL + +main :: IO () +main = do + defaultMain [ + --bgroup "call" [ + -- bench "incrementCount" $ nf undefined + -- bench "resetCount" $ nf undefined + --] + ] diff --git a/packages/distributed-process-client-server/distributed-process-client-server.cabal b/packages/distributed-process-client-server/distributed-process-client-server.cabal new file mode 100644 index 00000000..7016a0f7 --- /dev/null +++ b/packages/distributed-process-client-server/distributed-process-client-server.cabal @@ -0,0 +1,138 @@ +cabal-version: 3.0 +name: distributed-process-client-server +version: 0.2.5.1 +build-type: Simple +license: BSD-3-Clause +license-file: LICENCE +stability: experimental +Copyright: Tim Watson 2012 - 2017 +Author: Tim Watson +maintainer: The Distributed Haskell team +Homepage: http://github.com/haskell-distributed/distributed-process-client-server +Bug-Reports: http://github.com/haskell-distributed/distributed-process-client-server/issues +synopsis: The Cloud Haskell Application Platform +description: Modelled after Erlang OTP's gen_server, this framework provides similar + facilities for Cloud Haskell, grouping essential practices for client/server + development into a set of modules and standards designed to help you build + concurrent, distributed applications with relative ease. +category: Control +tested-with: GHC==8.10.7 GHC==9.0.2 GHC==9.2.8 GHC==9.4.5 GHC==9.6.4 GHC==9.8.2 GHC==9.10.1 + +source-repository head + type: git + location: https://github.com/haskell-distributed/distributed-process-client-server + +common warnings + ghc-options: -Wall + -Wcompat + -Widentities + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wredundant-constraints + -fhide-source-paths + -Wpartial-fields + +library + import: warnings + build-depends: + base >= 4.8.2.0 && < 5, + distributed-process >= 0.6.6 && < 0.8, + distributed-process-extras >= 0.3.1 && < 0.4, + distributed-process-async >= 0.2.4 && < 0.3, + binary >= 0.8 && < 0.9, + deepseq >= 1.4 && < 1.6, + mtl, + containers >= 0.6 && < 0.8, + hashable >= 1.2.0.5 && < 1.6, + unordered-containers >= 0.2.3.0 && < 0.3, + fingertree < 0.2, + stm >= 2.4 && < 2.6, + time > 1.4 && < 1.15, + transformers, + exceptions >= 0.10 && < 0.11 + hs-source-dirs: src + exposed-modules: + Control.Distributed.Process.ManagedProcess, + Control.Distributed.Process.ManagedProcess.Client, + Control.Distributed.Process.ManagedProcess.UnsafeClient, + Control.Distributed.Process.ManagedProcess.Server, + Control.Distributed.Process.ManagedProcess.Server.Priority, + Control.Distributed.Process.ManagedProcess.Server.Restricted, + Control.Distributed.Process.ManagedProcess.Server.Gen, + Control.Distributed.Process.ManagedProcess.Timer, + Control.Distributed.Process.ManagedProcess.Internal.Types, + Control.Distributed.Process.ManagedProcess.Internal.GenProcess + other-modules: Control.Distributed.Process.ManagedProcess.Internal.PriorityQueue + +test-suite ManagedProcessTests + import: warnings + type: exitcode-stdio-1.0 + x-uses-tf: true + build-depends: + base >= 4.14 && < 5, + ansi-terminal >= 0.5 && < 0.9, + containers, + distributed-process, + distributed-process-extras, + distributed-process-async, + distributed-process-client-server, + distributed-process-systest >= 0.1.1, + network-transport >= 0.4 && < 0.7, + mtl, + fingertree, + network-transport-tcp >= 0.6 && < 0.9, + binary >= 0.8 && < 0.9, + deepseq, + network >= 2.3 && < 3.3, + HUnit >= 1.2 && < 2, + stm, + test-framework >= 0.6 && < 0.9, + test-framework-hunit, + transformers, + rematch >= 0.2.0.0, + ghc-prim, + exceptions + other-modules: Counter, + ManagedProcessCommon, + MathsDemo, + SafeCounter, + TestUtils + hs-source-dirs: + tests + ghc-options: -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind + main-is: TestManagedProcess.hs + +test-suite PrioritisedProcessTests + import: warnings + type: exitcode-stdio-1.0 + x-uses-tf: true + build-depends: + base >= 4.14 && < 5, + ansi-terminal, + containers, + distributed-process, + distributed-process-extras, + distributed-process-async, + distributed-process-client-server, + distributed-process-systest >= 0.1.1, + network-transport, + mtl, + fingertree, + network-transport-tcp, + binary, + deepseq, + network, + HUnit, + stm, + test-framework, + test-framework-hunit, + transformers, + rematch, + ghc-prim, + exceptions + other-modules: ManagedProcessCommon, + TestUtils + hs-source-dirs: + tests + ghc-options: -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind + main-is: TestPrioritisedProcess.hs diff --git a/packages/distributed-process-client-server/src/Control/Distributed/Process/ManagedProcess.hs b/packages/distributed-process-client-server/src/Control/Distributed/Process/ManagedProcess.hs new file mode 100644 index 00000000..30fac64d --- /dev/null +++ b/packages/distributed-process-client-server/src/Control/Distributed/Process/ManagedProcess.hs @@ -0,0 +1,767 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ScopedTypeVariables #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Distributed.Process.ManagedProcess +-- Copyright : (c) Tim Watson 2012 - 2017 +-- License : BSD3 (see the file LICENSE) +-- +-- Maintainer : Tim Watson +-- Stability : experimental +-- Portability : non-portable (requires concurrency) +-- +-- This module provides a high(er) level API for building complex @Process@ +-- implementations by abstracting out the management of the process' mailbox, +-- reply/response handling, timeouts, process hiberation, error handling +-- and shutdown/stop procedures. It is modelled along similar lines to OTP's +-- gen_server API - . +-- +-- In particular, a /managed process/ will interoperate cleanly with the +-- supervisor API in distributed-process-supervision. +-- +-- [API Overview For The Impatient] +-- +-- Once started, a /managed process/ will consume messages from its mailbox and +-- pass them on to user defined /handlers/ based on the types received (mapped +-- to those accepted by the handlers) and optionally by also evaluating user +-- supplied predicates to determine which handler(s) should run. +-- Each handler returns a 'ProcessAction' which specifies how we should proceed. +-- If none of the handlers is able to process a message (because their types are +-- incompatible), then the 'unhandledMessagePolicy' will be applied. +-- +-- The 'ProcessAction' type defines the ways in which our process can respond +-- to its inputs, whether by continuing to read incoming messages, setting an +-- optional timeout, sleeping for a while, or stopping. The optional timeout +-- behaves a little differently to the other process actions: If no messages +-- are received within the specified time span, a user defined 'timeoutHandler' +-- will be called in order to determine the next action. +-- +-- The 'ProcessDefinition' type also defines a @shutdownHandler@, +-- which is called whenever the process exits, whether because a callback has +-- returned 'stop' as the next action, or as the result of unhandled exit signal +-- or similar asynchronous exceptions thrown in (or to) the process itself. +-- +-- The handlers are split into groups: /apiHandlers/, /infoHandlers/, and +-- /extHandlers/. +-- +-- [Seriously, TL;DR] +-- +-- Use 'serve' for a process that sits reading its mailbox and generally behaves +-- as you'd expect. Use 'pserve' and 'PrioritisedProcessDefinition' for a server +-- that manages its mailbox more comprehensively and handles errors a bit differently. +-- Both use the same client API. +-- +-- DO NOT mask in handler code, unless you can guarantee it won't be long +-- running and absolutely won't block kill signals from a supervisor. +-- +-- Do look at the various API offerings, as there are several, at different +-- levels of abstraction. +-- +-- [Managed Process Mailboxes] +-- +-- Managed processes come in two flavours, with different runtime characteristics +-- and (to some extent) semantics. These flavours are differentiated by the way +-- in which they handle the server process mailbox - all client interactions +-- remain the same. +-- +-- The /vanilla/ managed process mailbox, provided by the 'serve' API, is roughly +-- akin to a tail recursive /listen/ function that calls a list of passed in +-- matchers. We might naively implement it roughly like this: +-- +-- > +-- > loop :: stateT -> [(stateT -> Message -> Maybe stateT)] -> Process () +-- > loop state handlers = do +-- > st2 <- receiveWait $ map (\d -> handleMessage (d state)) handlers +-- > case st2 of +-- > Nothing -> {- we're done serving -} return () +-- > Just s2 -> loop s2 handlers +-- > +-- +-- Obviously all the details have been ellided, but this is the essential premise +-- behind a /managed process loop/. The process keeps reading from its mailbox +-- indefinitely, until either a handler instructs it to stop, or an asynchronous +-- exception (or exit signal - in the form of an async @ProcessExitException@) +-- terminates it. This kind of mailbox has fairly intuitive runtime characteristics +-- compared to a /plain server process/ (i.e. one implemented without the use of +-- this library): messages will pile up in its mailbox whilst handlers are +-- running, and each handler will be checked against the mailbox based on the +-- type of messages it recognises. We can potentially end up scanning a very +-- large mailbox trying to match each handler, which can be a performance +-- bottleneck depending on expected traffic patterns. +-- +-- For most simple server processes, this technique works well and is easy to +-- reason about a use. See the sections on error and exit handling later on for +-- more details about 'serve' based managed processes. +-- +-- [Prioritised Mailboxes] +-- +-- A prioritised mailbox serves two purposes. The first of these is to allow a +-- managed process author to specify that certain classes of message should be +-- prioritised by the server loop. This is achieved by draining the /real/ +-- process mailbox into an internal priority queue, and running the server's +-- handlers repeatedly over its contents, which are dequeued in priority order. +-- The obvious consequence of this approach leads to the second purpose (or the +-- accidental side effect, depending on your point of view) of a prioritised +-- mailbox, which is that we avoid scanning a large mailbox when searching for +-- messages that match the handlers we anticipate running most frequently (or +-- those messages that we deem most important). +-- +-- There are several consequences to this approach. One is that we do quite a bit +-- more work to manage the process mailbox behind the scenes, therefore we have +-- additional space overhead to consider (although we are also reducing the size +-- of the mailbox, so there is some counter balance here). The other is that if +-- we do not see the anticipated traffic patterns at runtime, then we might +-- spend more time attempting to prioritise infrequent messages than we would +-- have done simply receiving them! We do however, gain a degree of safety with +-- regards message loss that the 'serve' based /vanilla/ mailbox cannot offer. +-- See the sections on error and exit handling later on for more details about +-- these. +-- +-- A Prioritised 'pserve' loop maintains its internal state - including the user +-- defined /server state/ - in an @IORef@, ensuring it is held consistently +-- between executions, even in the face of unhandled exceptions. +-- +-- [Defining Prioritised Process Definitions] +-- +-- A 'PrioritisedProcessDefintion' combines the usual 'ProcessDefintion' - +-- containing the cast/call API, error, termination and info handlers - with a +-- list of 'Priority' entries, which are used at runtime to prioritise the +-- server's inputs. Note that it is only messages which are prioritised; The +-- server's various handlers are still evaluated in the order in which they +-- are specified in the 'ProcessDefinition'. +-- +-- Prioritisation does not guarantee that a prioritised message/type will be +-- processed before other traffic - indeed doing so in a multi-threaded runtime +-- would be very hard - but in the absence of races between multiple processes, +-- if two messages are both present in the process' own mailbox, they will be +-- applied to the ProcessDefinition's handlers in priority order. +-- +-- A prioritised process should probably be configured with a 'Priority' list to +-- be useful. Creating a prioritised process without any priorities could be a +-- potential waste of computational resources, and it is worth thinking carefully +-- about whether or not prioritisation is truly necessary in your design before +-- choosing to use it. +-- +-- Using a prioritised process is as simple as calling 'pserve' instead of +-- 'serve', and passing an initialised 'PrioritisedProcessDefinition'. +-- +-- [The Cast and Call Protocols] +-- +-- Deliberate interactions with a /managed process/ usually falls into one of +-- two categories. A 'cast' interaction involves a client sending a message +-- asynchronously and the server handling this input. No reply is sent to +-- the client. On the other hand, a 'call' is a /remote procedure call/, +-- where the client sends a message and waits for a reply from the server. +-- +-- All expressions given to @apiHandlers@ have to conform to the /cast or call/ +-- protocol. The protocol (messaging) implementation is hidden from the user; +-- API functions for creating user defined @apiHandlers@ are given instead, +-- which take expressions (i.e., a function or lambda expression) and create the +-- appropriate @Dispatcher@ for handling the cast (or call). +-- +-- These cast and call protocols are for dealing with /expected/ inputs. They +-- will usually form the explicit public API for the process, and be exposed by +-- providing module level functions that defer to the cast or call client API, +-- giving the process author an opportunity to enforce the correct input and +-- response types. For example: +-- +-- @ +-- {- Ask the server to add two numbers -} +-- add :: ProcessId -> Double -> Double -> Double +-- add pid x y = call pid (Add x y) +-- @ +-- +-- Note here that the return type from the call is /inferred/ and will not be +-- enforced by the type system. If the server sent a different type back in +-- the reply, then the caller might be blocked indefinitely! In fact, the +-- result of mis-matching the expected return type (in the client facing API) +-- with the actual type returned by the server is more severe in practise. +-- The underlying types that implement the /call/ protocol carry information +-- about the expected return type. If there is a mismatch between the input and +-- output types that the client API uses and those which the server declares it +-- can handle, then the message will be considered unroutable - no handler will +-- be executed against it and the unhandled message policy will be applied. You +-- should, therefore, take great care to align these types since the default +-- unhandled message policy is to terminate the server! That might seem pretty +-- extreme, but you can alter the unhandled message policy and/or use the +-- various overloaded versions of the call API in order to detect errors on the +-- server such as this. +-- +-- The cost of potential type mismatches between the client and server is the +-- main disadvantage of this looser coupling between them. This mechanism does +-- however, allow servers to handle a variety of messages without specifying the +-- entire protocol to be supported in excruciating detail. For that, we would +-- want /session types/, which are beyond the scope of this library. +-- +-- [Handling Unexpected/Info Messages] +-- +-- An explicit protocol for communicating with the process can be +-- configured using 'cast' and 'call', but it is not possible to prevent +-- other kinds of messages from being sent to the process mailbox. When +-- any message arrives for which there are no handlers able to process +-- its content, the 'UnhandledMessagePolicy' will be applied. Sometimes +-- it is desirable to process incoming messages which aren't part of the +-- protocol, rather than let the policy deal with them. This is particularly +-- true when incoming messages are important to the process, but their point +-- of origin is outside the author's control. Handling /signals/ such as +-- 'ProcessMonitorNotification' is a typical example of this: +-- +-- > handleInfo_ (\(ProcessMonitorNotification _ _ r) -> say $ show r >> continue_) +-- +-- [Handling Process State] +-- +-- The 'ProcessDefinition' is parameterised by the type of state it maintains. +-- A process that has no state will have the type @ProcessDefinition ()@ and can +-- be bootstrapped by evaluating 'statelessProcess'. +-- +-- All call/cast handlers come in two flavours, those which take the process +-- state as an input and those which do not. Handlers that ignore the process +-- state have to return a function that takes the state and returns the required +-- action. Versions of the various action generating functions ending in an +-- underscore are provided to simplify this: +-- +-- @ +-- statelessProcess { +-- apiHandlers = [ +-- handleCall_ (\\(n :: Int) -> return (n * 2)) +-- , handleCastIf_ (\\(c :: String, _ :: Delay) -> c == \"timeout\") +-- (\\(\"timeout\", (d :: Delay)) -> timeoutAfter_ d) +-- ] +-- , timeoutHandler = \\_ _ -> stop $ ExitOther \"timeout\" +-- } +-- @ +-- +-- [Avoiding Side Effects] +-- +-- If you wish to only write side-effect free code in your server definition, +-- then there is an explicit API for doing so. Instead of using the handler +-- definition functions in this module, import the /pure/ server module instead, +-- which provides a StateT based monad for building referentially transparent +-- callbacks. +-- +-- See "Control.Distributed.Process.ManagedProcess.Server.Restricted" for +-- details and API documentation. +-- +-- [Handling Errors] +-- +-- Error handling appears in several contexts and process definitions can +-- hook into these with relative ease. Catching exceptions inside handle +-- functions is no different to ordinary exception handling in monadic code. +-- +-- @ +-- handleCall (\\x y -> +-- catch (hereBeDragons x y) +-- (\\(e :: SmaugTheTerribleException) -> +-- return (Left (show e)))) +-- @ +-- +-- The caveats mentioned in "Control.Distributed.Process.Extras" about +-- exit signal handling are very important here - it is strongly advised that +-- you do not catch exceptions of type @ProcessExitException@ unless you plan +-- to re-throw them again. +-- +-- [Structured Exit Handling] +-- +-- Because "Control.Distributed.Process.ProcessExitException" is a ubiquitous +-- signalling mechanism in Cloud Haskell, it is treated unlike other +-- asynchronous exceptions. The 'ProcessDefinition' 'exitHandlers' field +-- accepts a list of handlers that, for a specific exit reason, can decide +-- how the process should respond. If none of these handlers matches the +-- type of @reason@ then the process will exit. with @DiedException why@. In +-- addition, a private /exit handler/ is installed for exit signals where +-- @(reason :: ExitReason) == ExitShutdown@, which is an of /exit signal/ used +-- explicitly by supervision APIs. This behaviour, which cannot be overriden, is +-- to gracefully shut down the process, calling the @shutdownHandler@ as usual, +-- before stopping with @reason@ given as the final outcome. +-- +-- /Example: handling custom data is @ProcessExitException@/ +-- +-- > handleExit (\state from (sigExit :: SomeExitData) -> continue s) +-- +-- Under some circumstances, handling exit signals is perfectly legitimate. +-- Handling of /other/ forms of asynchronous exception (e.g., exceptions not +-- generated by an /exit/ signal) is not supported by this API. Cloud Haskell's +-- primitives for exception handling /will/ work normally in managed process +-- callbacks, but you are strongly advised against swallowing exceptions in +-- general, or masking, unless you have carefully considered the consequences. +-- +-- [Different Mailbox Types and Exceptions: Message Loss] +-- +-- Neither the /vanilla/ nor the /prioritised/ mailbox implementations will +-- allow you to handle arbitrary asynchronous exceptions outside of your handler +-- code. The way in which the two mailboxes handle unexpected asynchronous +-- exceptions differs significantly however. The first consideration pertains to +-- potential message loss. +-- +-- Consider a plain Cloud Haskell expression such as the following: +-- +-- @ +-- catch (receiveWait [ match (\(m :: SomeType) -> doSomething m) ]) +-- (\(e :: SomeCustomAsyncException) -> handleExFrom e pid) +-- @ +-- +-- It is entirely possible that @receiveWait@ will succeed in matching a message +-- of type @SomeType@ from the mailbox and removing it, to be handed to the +-- supplied expression @doSomething@. Should an asynchronous exception arrive +-- at this moment in time, though the handler might run and allow the server to +-- recover, the message will be permanently lost. +-- +-- The mailbox exposed by 'serve' operates in exactly this way, and as such it +-- is advisible to avoid swallowing asynchronous exceptions, since doing so can +-- introduce the possibility of unexpected message loss. +-- +-- The prioritised mailbox exposed by 'pserve' on the other hand, does not suffer +-- this scenario. Whilst the mailbox is drained into the internal priority queue, +-- asynchronous exceptions are masked, and only once the queue has been updated +-- are they removed. In addition, it is possible to @peek@ at the priority queue +-- without removing a message, thereby ensuring that should the handler fail or +-- an asynchronous exception arrive whilst processing the message, we can resume +-- handling our message immediately upon recovering from the exception. This +-- behaviour allows the process to guarantee against message loss, whilst avoiding +-- masking within handlers, which is generally bad form (and can potentially lead +-- to zombie processes, when supervised servers refuse to respond to @kill@ +-- signals whilst stuck in a long running handler). +-- +-- Also note that a process' internal state is subject to the same semantics, +-- such that the arrival of an asynchronous exception (including exit signals!) +-- can lead to handlers (especially exit and shutdown handlers) running with +-- a stale version of their state. For this reason - since we cannot guarantee +-- an up to date state in the presence of these semantics - a shutdown handler +-- for a 'serve' loop will always have its state passed as @LastKnown stateT@. +-- +-- [Different Mailbox Types and Exceptions: Error Recovery And Shutdown] +-- +-- If any asynchronous exception goes unhandled by a /vanilla/ process, the +-- server will immediately exit without running the user supplied @shutdownHandler@. +-- It is very important to note that in Cloud Haskell, link failures generate +-- asynchronous exceptions in the target and these will NOT be caught by the 'serve' +-- API and will therefore cause the process to exit /without running the +-- termination handler/ callback. If your termination handler is set up to do +-- important work (such as resource cleanup) then you should avoid linking you +-- process and use monitors instead. If your code absolutely must run its +-- termination handlers in the face of any unhandled (async) exception, consider +-- using a prioritised mailbox, which handles this. Alternatively, consider +-- arranging your processes in a supervision tree, and using a shutdown strategy +-- to ensure that siblings terminate cleanly (based off a supervisor's ordered +-- shutdown signal) in order to ensure cleanup code can run reliably. +-- +-- As mentioned above, a prioritised mailbox behaves differently in the face +-- of unhandled asynchronous exceptions. Whilst 'pserve' still offers no means +-- for handling arbitrary async exceptions outside your handlers - and you should +-- avoid handling them within, to the maximum extent possible - it does execute +-- its receiving process in such a way that any unhandled exception will be +-- caught and rethrown. Because of this, and the fact that a prioritised process +-- manages its internal state in an @IORef@, shutdown handlers are guaranteed +-- to run even in the face of async exceptions. These are run with the latest +-- version of the server state available, given as @CleanShutdown stateT@ when +-- the process is terminating normally (i.e. for reasons @ExitNormal@ or +-- @ExitShutdown@), and @LastKnown stateT@ when an exception terminated the +-- server process abruptly. The latter acknowledges that we cannot guarantee +-- the exception did not interrupt us after the last handler ran and returned an +-- updated state, but prior to storing the update. +-- +-- Although shutdown handlers are run even in the face of unhandled exceptions +-- (and prior to re-throwing, when there is one present), they are not run in a +-- masked state. In fact, exceptions are explicitly unmasked prior to executing +-- a handler, therefore it is possible for a shutdown handler to terminate +-- abruptly. Once again, supervision hierarchies are a better way to ensure +-- consistent cleanup occurs when valued resources are held by a process. +-- +-- [Filters, pre-processing, and safe handlers] +-- +-- A prioritised process can take advantage of filters, which enable the server +-- to pre-process messages, reject them (based on the message itself, or the +-- server's state), and mark classes of message as requiring /safe/ handling. +-- +-- Assuming a 'PrioritisedProcessDefinition' that holds its state as an 'Int', +-- here are some simple applications of filters: +-- +-- > let rejectUnchecked = +-- > rejectApi Foo :: Int -> P.Message String String -> Process (Filter Int) +-- > +-- > filters = [ +-- > store (+1) +-- > , ensure (>0) +-- > +-- > , check $ api_ (\(s :: String) -> return $ "checked-" `isInfixOf` s) rejectUnchecked +-- > , check $ info (\_ (_ :: MonitorRef, _ :: ProcessId) -> return False) $ reject Foo +-- > , refuse ((> 10) :: Int -> Bool) +-- > ] +-- +-- We can store/update our state, ensure our state is in a valid condition, +-- check api and info messages, and refuse messages using simple predicates. +-- Messages cannot be modified by filters, not can reply data. +-- +-- A 'safe' filter is a means to instruct the prioritised managed process loop +-- not to dequeue the current message from the internal priority queue until a +-- handler has successfully matched and run against it (without an exception, +-- either synchronous or asynchronous) to completion. Messages marked thus, will +-- remain in the priority queue even in the face of exit signals, which means that +-- if the server process code handles and swallows them, it will begin re-processing +-- the last message a second time. +-- +-- It is important to recognise that the 'safe' filter does not act like a +-- transaction. There are no checkpoints, nor facilities for rolling back actions +-- on failure. If an exit signal terminates a handler for a message marked as +-- 'safe' and an exit handler catches and swallows it, the handler (and all prior +-- filters too) will be re-run in its entireity. +-- +-- [Special Clients: Control Channels] +-- +-- For advanced users and those requiring very low latency, a prioritised +-- process definition might not be suitable, since it performs considerable +-- work /behind the scenes/. There are also designs that need to segregate a +-- process' /control plane/ from other kinds of traffic it is expected to +-- receive. For such use cases, a /control channel/ may prove a better choice, +-- since typed channels are already prioritised during the mailbox scans that +-- the base @receiveWait@ and @receiveTimeout@ primitives from +-- distribute-process provides. +-- +-- In order to utilise a /control channel/ in a server, it must be passed to the +-- corresponding 'handleControlChan' function (or its stateless variant). The +-- control channel is created by evaluating 'newControlChan', in the same way +-- that we create regular typed channels. +-- +-- In order for clients to communicate with a server via its control channel +-- however, they must pass a handle to a 'ControlPort', which can be obtained by +-- evaluating 'channelControlPort' on the 'ControlChannel'. A 'ControlPort' is +-- @Serializable@, so they can alternatively be sent to other processes. +-- +-- /Control channel/ traffic will only be prioritised over other traffic if the +-- handlers using it are present before others (e.g., @handleInfo, handleCast@, +-- etc) in the process definition. It is not possible to combine prioritised +-- processes with /control channels/. Attempting to do so will satisfy the +-- compiler, but crash with a runtime error once you attempt to evaluate the +-- prioritised server loop (i.e., 'pserve'). +-- +-- Since the primary purpose of control channels is to simplify and optimise +-- client-server communication over a single channel, this module provides an +-- alternate server loop in the form of 'chanServe'. Instead of passing an +-- initialised 'ProcessDefinition', this API takes an expression from a +-- 'ControlChannel' to 'ProcessDefinition', operating in the 'Process' monad. +-- Providing the opaque reference in this fashion is useful, since the type of +-- messages the control channel carries will not correlate directly to the +-- inter-process traffic we use internally. +-- +-- Although control channels are intended for use as a single control plane +-- (via 'chanServe'), it /is/ possible to use them as a more strictly typed +-- communications backbone, since they do enforce absolute type safety in client +-- code, being bound to a particular type on creation. For rpc (i.e., 'call') +-- interaction however, it is not possible to have the server reply to a control +-- channel, since they're a /one way pipe/. It is possible to alleviate this +-- situation by passing a request type than contains a typed channel bound to +-- the expected reply type, enabling client and server to match on both the input +-- and output types as specifically as possible. Note that this still does not +-- guarantee an agreement on types between all parties at runtime however. +-- +-- An example of how to do this follows: +-- +-- > data Request = Request String (SendPort String) +-- > deriving (Typeable, Generic) +-- > instance Binary Request where +-- > +-- > -- note that our initial caller needs an mvar to obtain the control port... +-- > echoServer :: MVar (ControlPort Request) -> Process () +-- > echoServer mv = do +-- > cc <- newControlChan :: Process (ControlChannel Request) +-- > liftIO $ putMVar mv $ channelControlPort cc +-- > let s = statelessProcess { +-- > apiHandlers = [ +-- > handleControlChan_ cc (\(Request m sp) -> sendChan sp m >> continue_) +-- > ] +-- > } +-- > serve () (statelessInit Infinity) s +-- > +-- > echoClient :: String -> ControlPort Request -> Process String +-- > echoClient str cp = do +-- > (sp, rp) <- newChan +-- > sendControlMessage cp $ Request str sp +-- > receiveChan rp +-- +-- [Communicating with the outside world: External (STM) Input Channels] +-- +-- Both client and server APIs provide a mechanism for interacting with a running +-- server process via STM. This is primarily intended for code that runs outside +-- of Cloud Haskell's /Process/ monad, but can also be used as a channel for +-- sending and/or receiving non-serializable data to or from a managed process. +-- Obviously if you attempt to do this across a remote boundary, things will go +-- spectacularly wrong. The APIs provided do not attempt to restrain this, or +-- to impose any particular scheme on the programmer, therefore you're on your +-- own when it comes to writing the /STM/ code for reading and writing data +-- between client and server. +-- +-- For code running inside the /Process/ monad and passing Serializable thunks, +-- there is no real advantage to this approach, and indeed there are several +-- serious disadvantages - none of Cloud Haskell's ordering guarantees will hold +-- when passing data to and from server processes in this fashion, nor are there +-- any guarantees the runtime system can make with regards interleaving between +-- messages passed across Cloud Haskell's communication fabric vs. data shared +-- via STM. This is true even when client(s) and server(s) reside on the same +-- local node. +-- +-- A server wishing to receive data via STM can do so using the @handleExternal@ +-- API. By way of example, here is a simple echo server implemented using STM: +-- +-- > demoExternal = do +-- > inChan <- liftIO newTQueueIO +-- > replyQ <- liftIO newTQueueIO +-- > let procDef = statelessProcess { +-- > apiHandlers = [ +-- > handleExternal +-- > (readTQueue inChan) +-- > (\s (m :: String) -> do +-- > liftIO $ atomically $ writeTQueue replyQ m +-- > continue s) +-- > ] +-- > } +-- > let txt = "hello 2-way stm foo" +-- > pid <- spawnLocal $ serve () (statelessInit Infinity) procDef +-- > echoTxt <- liftIO $ do +-- > -- firstly we write something that the server can receive +-- > atomically $ writeTQueue inChan txt +-- > -- then sit and wait for it to write something back to us +-- > atomically $ readTQueue replyQ +-- > +-- > say (show $ echoTxt == txt) +-- +-- For request/reply channels such as this, a convenience based on the call API +-- is also provided, which allows the server author to write an ordinary call +-- handler, and the client author to utilise an API that monitors the server and +-- does the usual stuff you'd expect an RPC style client to do. Here is another +-- example of this in use, demonstrating the @callSTM@ and @handleCallExternal@ +-- APIs in practise. +-- +-- > data StmServer = StmServer { serverPid :: ProcessId +-- > , writerChan :: TQueue String +-- > , readerChan :: TQueue String +-- > } +-- > +-- > instance Resolvable StmServer where +-- > resolve = return . Just . serverPid +-- > +-- > echoStm :: StmServer -> String -> Process (Either ExitReason String) +-- > echoStm StmServer{..} = callSTM serverPid +-- > (writeTQueue writerChan) +-- > (readTQueue readerChan) +-- > +-- > launchEchoServer :: CallHandler () String String -> Process StmServer +-- > launchEchoServer handler = do +-- > (inQ, replyQ) <- liftIO $ do +-- > cIn <- newTQueueIO +-- > cOut <- newTQueueIO +-- > return (cIn, cOut) +-- > +-- > let procDef = statelessProcess { +-- > apiHandlers = [ +-- > handleCallExternal +-- > (readTQueue inQ) +-- > (writeTQueue replyQ) +-- > handler +-- > ] +-- > } +-- > +-- > pid <- spawnLocal $ serve () (statelessInit Infinity) procDef +-- > return $ StmServer pid inQ replyQ +-- > +-- > testExternalCall :: TestResult Bool -> Process () +-- > testExternalCall result = do +-- > let txt = "hello stm-call foo" +-- > srv <- launchEchoServer (\st (msg :: String) -> reply msg st) +-- > echoStm srv txt >>= stash result . (== Right txt) +-- +-- [Performance Considerations] +-- +-- The various server loops are fairly optimised, but there /is/ a definite +-- cost associated with scanning the mailbox to match on protocol messages, +-- plus additional costs in space and time due to mapping over all available +-- /info handlers/ for non-protocol (i.e., neither /call/ nor /cast/) messages. +-- These are exacerbated significantly when using prioritisation, whilst using +-- a single control channel is very fast and carries little overhead. +-- +-- From the client perspective, it's important to remember that the /call/ +-- protocol will wait for a reply in most cases, triggering a full O(n) scan of +-- the caller's mailbox. If the mailbox is extremely full and calls are +-- regularly made, this may have a significant impact on the caller. The +-- @callChan@ family of client API functions can alleviate this, by using (and +-- matching on) a private typed channel instead, but the server must be written +-- to accomodate this. Similar gains can be had using a /control channel/ and +-- providing a typed reply channel in the request data, however the 'call' +-- mechanism does not support this notion, so not only are we unable +-- to use the various /reply/ functions, client code should also consider +-- monitoring the server's pid and handling server failures whilst waiting on +-- +----------------------------------------------------------------------------- + +module Control.Distributed.Process.ManagedProcess + ( -- * Starting/Running server processes + InitResult(..) + , InitHandler + , serve + , pserve + , chanServe + , runProcess + , prioritised + -- * Client interactions + , module Control.Distributed.Process.ManagedProcess.Client + -- * Defining server processes + , ProcessDefinition(..) + , PrioritisedProcessDefinition(..) + , RecvTimeoutPolicy(..) + , Priority() + , DispatchPriority() + , ShutdownHandler + , TimeoutHandler + , Condition + , Action + , ProcessAction() + , Reply + , ProcessReply() + , ActionHandler + , CallHandler + , CastHandler + , StatelessHandler + , DeferredCallHandler + , StatelessCallHandler + , InfoHandler + , ChannelHandler + , StatelessChannelHandler + , UnhandledMessagePolicy(..) + , CallRef + , ExitState(..) + , isCleanShutdown + , exitState + , defaultProcess + , defaultProcessWithPriorities + , statelessProcess + , statelessInit + -- * Control channels + , ControlChannel() + , ControlPort() + , newControlChan + , channelControlPort + -- * Server side callbacks + , module Control.Distributed.Process.ManagedProcess.Server + -- * Prioritised mailboxes + , module P + -- * Low level and internal APIs & Process implementation + , module Gen + ) where + +import Control.Distributed.Process hiding (call, Message) +import Control.Distributed.Process.ManagedProcess.Client +import Control.Distributed.Process.ManagedProcess.Server +import qualified Control.Distributed.Process.ManagedProcess.Server.Restricted as R +import qualified Control.Distributed.Process.ManagedProcess.Server.Priority as P hiding (reject) +import qualified Control.Distributed.Process.ManagedProcess.Internal.GenProcess as Gen +import Control.Distributed.Process.ManagedProcess.Internal.GenProcess +import Control.Distributed.Process.ManagedProcess.Internal.Types hiding (runProcess) +import Control.Distributed.Process.Extras (ExitReason(..)) +import Control.Distributed.Process.Extras.Time +import Control.Distributed.Process.Serializable +import Prelude hiding (init) + +-- TODO: automatic registration + +-- | Starts the /message handling loop/ for a managed process configured with +-- the supplied process definition, after calling the init handler with its +-- initial arguments. Note that this function does not return until the server +-- exits. +serve :: a + -> InitHandler a s + -> ProcessDefinition s + -> Process () +serve argv init def = runProcess (recvLoop def) argv init + +-- | Starts the /message handling loop/ for a prioritised managed process, +-- configured with the supplied process definition, after calling the init +-- handler with its initial arguments. Note that this function does not return +-- until the server exits. +pserve :: a + -> InitHandler a s + -> PrioritisedProcessDefinition s + -> Process () +pserve argv init def = runProcess (precvLoop def) argv init + +-- | Starts the /message handling loop/ for a managed process, configured with +-- a typed /control channel/. The caller supplied expression is evaluated with +-- an opaque reference to the channel, which must be passed when calling +-- @handleControlChan@. The meaning and behaviour of the init handler and +-- initial arguments are the same as those given to 'serve'. Note that this +-- function does not return until the server exits. +-- +chanServe :: (Serializable b) + => a + -> InitHandler a s + -> (ControlChannel b -> Process (ProcessDefinition s)) + -> Process () +chanServe argv init mkDef = do + pDef <- mkDef . ControlChannel =<< newChan + runProcess (recvLoop pDef) argv init + +-- | Wraps any /process loop/ and ensures that it adheres to the +-- managed process start/stop semantics, i.e., evaluating the +-- @InitHandler@ with an initial state and delay will either +-- @die@ due to @InitStop@, exit silently (due to @InitIgnore@) +-- or evaluate the process' @loop@. The supplied @loop@ must evaluate +-- to @ExitNormal@, otherwise the calling processing will @die@ with +-- whatever @ExitReason@ is given. +-- +runProcess :: (s -> Delay -> Process ExitReason) + -> a + -> InitHandler a s + -> Process () +runProcess loop args init = do + ir <- init args + case ir of + InitOk s d -> loop s d >>= checkExitType + InitStop s -> die $ ExitOther s + InitIgnore -> return () + where + checkExitType :: ExitReason -> Process () + checkExitType ExitNormal = return () + checkExitType ExitShutdown = return () + checkExitType other = die other + +-- | A default 'ProcessDefinition', with no api, info or exit handler. +-- The default 'timeoutHandler' simply continues, the 'shutdownHandler' +-- is a no-op and the 'unhandledMessagePolicy' is @Terminate@. +defaultProcess :: ProcessDefinition s +defaultProcess = ProcessDefinition { + apiHandlers = [] + , infoHandlers = [] + , externHandlers = [] + , exitHandlers = [] + , timeoutHandler = \s _ -> continue s + , shutdownHandler = \_ _ -> return () + , unhandledMessagePolicy = Terminate + } :: ProcessDefinition s + +-- | Turns a standard 'ProcessDefinition' into a 'PrioritisedProcessDefinition', +-- by virtue of the supplied list of 'DispatchPriority' expressions. +-- +prioritised :: ProcessDefinition s + -> [DispatchPriority s] + -> PrioritisedProcessDefinition s +prioritised def ps = + PrioritisedProcessDefinition def ps [] defaultRecvTimeoutPolicy + +-- | Sets the default 'recvTimeoutPolicy', which gives up after 10k reads. +defaultRecvTimeoutPolicy :: RecvTimeoutPolicy +defaultRecvTimeoutPolicy = RecvMaxBacklog 10000 + +-- | Creates a default 'PrioritisedProcessDefinition' from a list of +-- 'DispatchPriority'. See 'defaultProcess' for the underlying definition. +defaultProcessWithPriorities :: [DispatchPriority s] -> PrioritisedProcessDefinition s +defaultProcessWithPriorities = prioritised defaultProcess + +-- | A basic, stateless 'ProcessDefinition'. See 'defaultProcess' for the +-- default field values. +statelessProcess :: ProcessDefinition () +statelessProcess = defaultProcess :: ProcessDefinition () + +-- | A default, state /unaware/ 'InitHandler' that can be used with +-- 'statelessProcess'. This simply returns @InitOk@ with the empty +-- state (i.e., unit) and the given 'Delay'. +statelessInit :: Delay -> InitHandler () () +statelessInit d () = return $ InitOk () d diff --git a/packages/distributed-process-client-server/src/Control/Distributed/Process/ManagedProcess/Client.hs b/packages/distributed-process-client-server/src/Control/Distributed/Process/ManagedProcess/Client.hs new file mode 100644 index 00000000..4b34ddeb --- /dev/null +++ b/packages/distributed-process-client-server/src/Control/Distributed/Process/ManagedProcess/Client.hs @@ -0,0 +1,254 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ScopedTypeVariables #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Distributed.Process.ManagedProcess.Client +-- Copyright : (c) Tim Watson 2012 - 2017 +-- License : BSD3 (see the file LICENSE) +-- +-- Maintainer : Tim Watson +-- Stability : experimental +-- Portability : non-portable (requires concurrency) +-- +-- The Client Portion of the /Managed Process/ API. +----------------------------------------------------------------------------- + +module Control.Distributed.Process.ManagedProcess.Client + ( -- * API for client interactions with the process + sendControlMessage + , shutdown + , call + , safeCall + , tryCall + , callTimeout + , flushPendingCalls + , callAsync + , cast + , callChan + , syncCallChan + , syncSafeCallChan + , callSTM + ) where + +import Control.Concurrent.STM (atomically, STM) +import Control.Distributed.Process hiding (call, finally) +import Control.Distributed.Process.Serializable +import Control.Distributed.Process.Async hiding (check) +import Control.Distributed.Process.ManagedProcess.Internal.Types hiding (liftIO) +import qualified Control.Distributed.Process.ManagedProcess.Internal.Types as T +import Control.Distributed.Process.Extras.Internal.Types (resolveOrDie) +import Control.Distributed.Process.Extras hiding (monitor, sendChan) +import Control.Distributed.Process.Extras.Time +import Control.Monad.Catch (finally) +import Data.Maybe (fromJust) + +import Prelude hiding (init) + +-- | Send a control message over a 'ControlPort'. +-- +sendControlMessage :: Serializable m => ControlPort m -> m -> Process () +sendControlMessage cp m = sendChan (unPort cp) (CastMessage m) + +-- | Send a signal instructing the process to terminate. The /receive loop/ which +-- manages the process mailbox will prioritise @Shutdown@ signals higher than +-- any other incoming messages, but the server might be busy (i.e., still in the +-- process of excuting a handler) at the time of sending however, so the caller +-- should not make any assumptions about the timeliness with which the shutdown +-- signal will be handled. If responsiveness is important, a better approach +-- might be to send an /exit signal/ with 'Shutdown' as the reason. An exit +-- signal will interrupt any operation currently underway and force the running +-- process to clean up and terminate. +shutdown :: ProcessId -> Process () +shutdown pid = cast pid Shutdown + +-- | Make a synchronous call - will block until a reply is received. +-- The calling process will exit with 'ExitReason' if the calls fails. +-- +-- __NOTE: this function does not catch exceptions!__ +-- +call :: forall s a b . (Addressable s, Serializable a, Serializable b) + => s -> a -> Process b +call sid msg = initCall sid msg >>= waitResponse Nothing >>= decodeResult + where decodeResult (Just (Right r)) = return r + decodeResult (Just (Left err)) = die err + decodeResult Nothing {- the impossible happened -} = terminate + +-- | Safe version of 'call' that returns information about the error +-- if the operation fails. If the calling process dies (that is, forces itself +-- to exit such that an exit signal arises with @ExitOther String@) then +-- evaluation will return @Left exitReason@ and the explanation will be +-- stashed away as @(ExitOther String)@. +-- +-- __NOTE: this function does not catch exceptions!__ +-- +-- The /safety/ of the name, comes from carefully handling situations in which +-- the server dies while we're waiting for a reply. Notably, exit signals from +-- other processes, kill signals, and both synchronous and asynchronous +-- exceptions can still terminate the caller abruptly. To avoid this consider +-- masking or evaluating within your own exception handling code. +-- +safeCall :: forall s a b . (Addressable s, Serializable a, Serializable b) + => s -> a -> Process (Either ExitReason b) +safeCall s m = do + us <- getSelfPid + (fmap fromJust (initCall s m >>= waitResponse Nothing) :: Process (Either ExitReason b)) + `catchesExit` [(\pid msg -> handleMessageIf msg (weFailed pid us) + (return . Left))] + where + weFailed a b (ExitOther _) = a == b + weFailed _ _ _ = False + +-- | Version of 'safeCall' that returns 'Nothing' if the operation fails. If +-- you need information about *why* a call has failed then you should use +-- 'safeCall' or combine @catchExit@ and @call@ instead. +-- +-- __NOTE: this function does not catch exceptions!__ +-- +-- In fact, this API handles fewer exceptions than it's relative, "safeCall". +-- Notably, exit signals, kill signals, and both synchronous and asynchronous +-- exceptions can still terminate the caller abruptly. To avoid this consider +-- masking or evaluating within your own exception handling code (as mentioned +-- above). +-- +tryCall :: forall s a b . (Addressable s, Serializable a, Serializable b) + => s -> a -> Process (Maybe b) +tryCall s m = initCall s m >>= waitResponse Nothing >>= decodeResult + where decodeResult (Just (Right r)) = return $ Just r + decodeResult _ = return Nothing + +-- | Make a synchronous call, but timeout and return @Nothing@ if a reply +-- is not received within the specified time interval. +-- +-- If the result of the call is a failure (or the call was cancelled) then +-- the calling process will exit, with the 'ExitReason' given as the reason. +-- If the call times out however, the semantics on the server side are +-- undefined, i.e., the server may or may not successfully process the +-- request and may (or may not) send a response at a later time. From the +-- callers perspective, this is somewhat troublesome, since the call result +-- cannot be decoded directly. In this case, the "flushPendingCalls" API /may/ +-- be used to attempt to receive the message later on, however this makes +-- /no attempt whatsoever/ to guarantee /which/ call response will in fact +-- be returned to the caller. In those semantics are unsuited to your +-- application, you might choose to @exit@ or @die@ in case of a timeout, +-- or alternatively, use the 'callAsync' API and associated @waitTimeout@ +-- function (in the /Async API/), which takes a re-usable handle on which +-- to wait (with timeouts) multiple times. +-- +callTimeout :: forall s a b . (Addressable s, Serializable a, Serializable b) + => s -> a -> TimeInterval -> Process (Maybe b) +callTimeout s m d = initCall s m >>= waitResponse (Just d) >>= decodeResult + where decodeResult :: (Serializable b) + => Maybe (Either ExitReason b) + -> Process (Maybe b) + decodeResult Nothing = return Nothing + decodeResult (Just (Right result)) = return $ Just result + decodeResult (Just (Left reason)) = die reason + +-- | Attempt to flush out any pending call responses. +flushPendingCalls :: forall b . (Serializable b) + => TimeInterval + -> (b -> Process b) + -> Process (Maybe b) +flushPendingCalls d proc = + receiveTimeout (asTimeout d) [ + match (\(CallResponse (m :: b) _) -> proc m) + ] + +-- | Invokes 'call' /out of band/, and returns an /async handle/. +-- +callAsync :: forall s a b . (Addressable s, Serializable a, Serializable b) + => s -> a -> Process (Async b) +callAsync server msg = async $ task $ call server msg + +-- | Sends a /cast/ message to the server identified by @server@. The server +-- will not send a response. Like Cloud Haskell's 'send' primitive, cast is +-- fully asynchronous and /never fails/ - therefore 'cast'ing to a non-existent +-- (e.g., dead) server process will not generate an error. +-- +cast :: forall a m . (Addressable a, Serializable m) + => a -> m -> Process () +cast server msg = sendTo server (CastMessage msg :: T.Message m ()) + +-- | Sends a /channel/ message to the server and returns a @ReceivePort@ on +-- which the reponse can be delivered, if the server so chooses (i.e., the +-- might ignore the request or crash). +callChan :: forall s a b . (Addressable s, Serializable a, Serializable b) + => s -> a -> Process (ReceivePort b) +callChan server msg = do + (sp, rp) <- newChan + sendTo server (ChanMessage msg sp :: T.Message a b) + return rp + +-- | A synchronous version of 'callChan'. +syncCallChan :: forall s a b . (Addressable s, Serializable a, Serializable b) + => s -> a -> Process b +syncCallChan server msg = do + r <- syncSafeCallChan server msg + case r of + Left e -> die e + Right r' -> return r' + +-- | A safe version of 'syncCallChan', which returns @Left ExitReason@ if the +-- call fails. +syncSafeCallChan :: forall s a b . (Addressable s, Serializable a, Serializable b) + => s -> a -> Process (Either ExitReason b) +syncSafeCallChan server msg = do + rp <- callChan server msg + awaitResponse server [ matchChan rp (return . Right) ] + +-- | Manages an rpc-style interaction with a server process, using @STM@ actions +-- to read/write data. The server process is monitored for the duration of the +-- /call/. The stm write expression is passed the input, and the read expression +-- is evaluated and the result given as @Right b@ or @Left ExitReason@ if a +-- monitor signal is detected whilst waiting. +-- +-- Note that the caller will exit (with @ExitOther String@) if the server +-- address is un-resolvable. +-- +-- A note about scheduling and timing guarantees (or lack thereof): It is not +-- possibly to guarantee the contents of @ExitReason@ in cases where this API +-- fails due to server exits/crashes. We establish a monitor prior to evaluating +-- the stm writer action, however @monitor@ is asychronous and we've no way to +-- know whether or not the scheduler will allow monitor establishment to proceed +-- first, or the stm transaction. As a result, assuming that your server process +-- can die/fail/exit on evaluating the read end of the STM write we perform here +-- (and we assume this is very likely, since we apply no safety rules and do not +-- even worry about serializing thunks passed from the client's thread), it is +-- just as likely that in the case of failure you will see a reason such as +-- @ExitOther "DiedUnknownId"@ due to the server process crashing before the node +-- controller can establish a monitor. +-- +-- As unpleasant as this is, there's little we can do about it without making +-- false assumptions about the runtime. Cloud Haskell's semantics guarantee us +-- only that we will see /some/ monitor signal in the event of a failure here. +-- To provide a more robust error handling, you can catch/trap failures in the +-- server process and return a wrapper reponse datum here instead. This will +-- /still/ be subject to the failure modes described above in cases where the +-- server process exits abnormally, but that will at least allow the caller to +-- differentiate between expected and exceptional failure conditions. +-- +callSTM :: forall s a b . (Addressable s) + => s + -> (a -> STM ()) + -> STM b + -> a + -> Process (Either ExitReason b) +callSTM server writeAction readAction input = do + -- NB: we must establish the monitor before writing, to ensure we have + -- a valid ref such that server failure gets reported properly + pid <- resolveOrDie server "callSTM: unresolveable address " + mRef <- monitor pid + + liftIO $ atomically $ writeAction input + + finally (receiveWait [ matchRef mRef + , matchSTM readAction (return . Right) + ]) + (unmonitor mRef) + + where + matchRef :: MonitorRef -> Match (Either ExitReason b) + matchRef r = matchIf (\(ProcessMonitorNotification r' _ _) -> r == r') + (\(ProcessMonitorNotification _ _ d) -> + return (Left (ExitOther (show d)))) diff --git a/packages/distributed-process-client-server/src/Control/Distributed/Process/ManagedProcess/Internal/GenProcess.hs b/packages/distributed-process-client-server/src/Control/Distributed/Process/ManagedProcess/Internal/GenProcess.hs new file mode 100644 index 00000000..d77ccc26 --- /dev/null +++ b/packages/distributed-process-client-server/src/Control/Distributed/Process/ManagedProcess/Internal/GenProcess.hs @@ -0,0 +1,825 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Rank2Types #-} + +-- | This is the @Process@ implementation of a /managed process/ +module Control.Distributed.Process.ManagedProcess.Internal.GenProcess + ( recvLoop + , precvLoop + , currentTimeout + , systemTimeout + , drainTimeout + , processState + , processDefinition + , processFilters + , processUnhandledMsgPolicy + , processQueue + , gets + , getAndModifyState + , modifyState + , setUserTimeout + , setProcessState + , GenProcess + , peek + , push + , enqueue + , dequeue + , addUserTimer + , removeUserTimer + , eval + , act + , runAfter + , evalAfter + ) where + +import Control.Applicative (liftA2) +import Control.Distributed.Process + ( match + , matchAny + , matchMessage + , handleMessage + , handleMessageIf + , receiveTimeout + , receiveWait + , forward + , catchesExit + , catchExit + , die + , unsafeWrapMessage + , Process + , ProcessId + , Match + ) +import qualified Control.Distributed.Process as P + ( liftIO + ) +import Control.Distributed.Process.Internal.Types + ( Message(..) + , ProcessExitException(..) + ) +import Control.Distributed.Process.ManagedProcess.Server + ( handleCast + , handleExitIf + , stop + , continue + ) +import Control.Distributed.Process.ManagedProcess.Timer + ( Timer(timerDelay) + , TimerKey + , TimedOut(..) + , delayTimer + , startTimer + , stopTimer + , matchTimeout + , matchKey + , matchRun + ) +import Control.Distributed.Process.ManagedProcess.Internal.Types hiding (Message) +import qualified Control.Distributed.Process.ManagedProcess.Internal.PriorityQueue as Q + ( empty + , dequeue + , enqueue + , peek + , toList + ) +import Control.Distributed.Process.Extras + ( ExitReason(..) + , Shutdown(..) + ) +import qualified Control.Distributed.Process.Extras.SystemLog as Log +import Control.Distributed.Process.Extras.Time +import Control.Distributed.Process.Serializable (Serializable) +import Control.Monad (void) +import Control.Monad.Catch + ( mask_ + , catch + , throwM + , mask + , SomeException + ) +import qualified Control.Monad.State.Strict as ST + ( get + ) +import Data.IORef (newIORef, atomicModifyIORef') +import Data.Maybe (fromJust) +import qualified Data.Map.Strict as Map + ( size + , insert + , delete + , lookup + , empty + , foldrWithKey + ) + +-------------------------------------------------------------------------------- +-- Priority Mailbox Handling -- +-------------------------------------------------------------------------------- + +type Safe = Bool + +-- | Evaluate the given function over the @ProcessState s@ for the caller, and +-- return the result. +gets :: forall s a . (ProcessState s -> a) -> GenProcess s a +gets f = ST.get >>= \(s :: State s) -> liftIO $ do + atomicModifyIORef' s $ \(s' :: ProcessState s) -> (s', f s' :: a) + +-- | Modify our state. +modifyState :: (ProcessState s -> ProcessState s) -> GenProcess s () +modifyState f = + ST.get >>= \s -> liftIO $ mask_ $ do + atomicModifyIORef' s $ \s' -> (f s', ()) + +-- | Modify our state and return a value (potentially from it). +getAndModifyState :: (ProcessState s -> (ProcessState s, a)) + -> GenProcess s a +getAndModifyState f = + ST.get >>= \s -> liftIO $ mask_ $ do + atomicModifyIORef' s $ \s' -> f s' + +-- | Set the current process state. +setProcessState :: s -> GenProcess s () +setProcessState st' = + modifyState $ \st@ProcessState{..} -> st { procState = st' } + +-- | Set the mailbox draining timer. +setDrainTimeout :: Timer -> GenProcess s () +setDrainTimeout t = modifyState $ \st@ProcessState{..} -> st { sysTimeout = t } + +-- | Set the user timeout applied whilst a prioritised process loop is in +-- a blocking receive. +setUserTimeout :: Delay -> GenProcess s () +setUserTimeout d = + modifyState $ \st@ProcessState{..} -> st { usrTimeout = d } + +-- | Add a /user timer/, bound to the given datum. +addUserTimer :: Timer -> Message -> GenProcess s TimerKey +addUserTimer t m = + getAndModifyState $ \st@ProcessState{..} -> + let sz = Map.size usrTimers + tk = sz + 1 + in (st { usrTimers = (Map.insert tk (t, m) usrTimers) }, tk) + +-- | Remove a /user timer/, for the given key. +removeUserTimer :: TimerKey -> GenProcess s () +removeUserTimer i = + modifyState $ \st@ProcessState{..} -> st { usrTimers = (Map.delete i usrTimers) } + +-- | Consume the timer with the given @TimerKey@. The timer is removed from the +-- @ProcessState@ and given to the supplied expression, whose evaluation is given +-- back to the caller. +consumeTimer :: forall s a . TimerKey -> (Message -> GenProcess s a) -> GenProcess s a +consumeTimer k f = do + mt <- gets usrTimers + let tm = Map.lookup k mt + let ut = Map.delete k mt + modifyState $ \st@ProcessState{..} -> st { usrTimers = ut } + case tm of + Nothing -> lift $ die $ "GenProcess.consumeTimer - InvalidTimerKey" + Just (_, m) -> f m + +-- | The @ProcessDefinition@ for the current loop. +processDefinition :: GenProcess s (ProcessDefinition s) +processDefinition = gets procDef + +-- | The list of prioritisers for the current loop. +processPriorities :: GenProcess s ([DispatchPriority s]) +processPriorities = gets procPrio + +-- | The list of filters for the current loop. +processFilters :: GenProcess s ([DispatchFilter s]) +processFilters = gets procFilters + +-- | Evaluates to the user defined state for the currently executing server loop. +processState :: GenProcess s s +processState = gets procState + +-- | Evaluates to the @UnhandledMessagePolicy@ for the current loop. +processUnhandledMsgPolicy :: GenProcess s UnhandledMessagePolicy +processUnhandledMsgPolicy = gets (unhandledMessagePolicy . procDef) + +-- | Returns a /read only view/ on the internal priority queue. +processQueue :: GenProcess s [Message] +processQueue = gets internalQ >>= return . Q.toList + +-- | The @Timer@ for the system timeout. See @drainTimeout@. +systemTimeout :: GenProcess s Timer +systemTimeout = gets sysTimeout + +-- | The policy for the system timeout. This is used to determine how the loop +-- should limit the time spent draining the /real/ process mailbox into our +-- internal priority queue. +timeoutPolicy :: GenProcess s RecvTimeoutPolicy +timeoutPolicy = gets timeoutSpec + +-- | The @Delay@ for the @drainTimeout@. +drainTimeout :: GenProcess s Delay +drainTimeout = gets (timerDelay . sysTimeout) + +-- | The current (user supplied) timeout. +currentTimeout :: GenProcess s Delay +currentTimeout = gets usrTimeout + +-- | Update and store the internal priority queue. +updateQueue :: (Queue -> Queue) -> GenProcess s () +updateQueue f = + modifyState $ \st@ProcessState{..} -> st { internalQ = f internalQ } + +-- | Evaluate any matching /info handler/ with the supplied datum after waiting +-- for at least @TimeInterval@. The process state (for the resulting @Action s@) +-- is also given and the process loop will go on as per @Server.continue@. +-- +-- Informally, evaluating this expression (such that the @Action@ is given as the +-- result of a handler or filter) will ensure that the supplied message (datum) +-- is availble for processing no sooner than @TimeInterval@. +-- +-- Currently, this expression creates an @Action@ that triggers immediate +-- evaluation in the process loop before continuing with the given state. The +-- process loop stores a /user timeout/ for the given time interval, which is +-- trigerred like a wait/drain timeout. This implementation is subject to change. +evalAfter :: forall s m . (Serializable m) => TimeInterval -> m -> s -> Action s +evalAfter d m s = act $ runAfter d m >> setProcessState s + +-- | Produce an @Action s@ that, if it is the result of a handler, will cause the +-- server loop to evaluate the supplied expression. This is given in the @GenProcess@ +-- monad, which is intended for internal use only. +act :: forall s . GenProcess s () -> Action s +act = return . ProcessActivity +{-# WARNING act "This interface is intended for internal use only" #-} + +-- | Evaluate an expression in the 'GenProcess' monad. +eval :: forall s . GenProcess s (ProcessAction s) -> Action s +eval = return . ProcessExpression + +-- | Starts a timer and adds it as a /user timeout/. +runAfter :: forall s m . (Serializable m) => TimeInterval -> m -> GenProcess s () +runAfter d m = do + t <- lift $ startTimer (Delay d) + void $ addUserTimer t (unsafeWrapMessage m) +{-# WARNING runAfter "This interface is intended for internal use only" #-} + +-------------------------------------------------------------------------------- +-- Internal Priority Queue -- +-------------------------------------------------------------------------------- + +-- | Dequeue a message from the internal priority queue. +dequeue :: GenProcess s (Maybe Message) +dequeue = getAndModifyState $ \st -> do + let pq = internalQ st + case Q.dequeue pq of + Nothing -> (st, Nothing) + Just (m, q') -> (st { internalQ = q' }, Just m) + +-- | Peek at the next available message in the internal priority queue, without +-- removing it. +peek :: GenProcess s (Maybe Message) +peek = getAndModifyState $ \st -> do + let pq = internalQ st + (st, Q.peek pq) + +-- | Push a message to the head of the internal priority queue. +push :: forall s . Message -> GenProcess s () +push m = do + st <- processState + enqueueMessage st [ PrioritiseInfo { + prioritise = (\_ m' -> + return $ Just ((101 :: Int), m')) :: s -> Message -> Process (Maybe (Int, Message)) } ] m + +-- | Enqueue a message to the back of the internal priority queue. +enqueue :: forall s . Message -> GenProcess s () +enqueue m = do + st <- processState + enqueueMessage st [] m + +-- | Enqueue a message in the internal priority queue. The given message will be +-- evaluated by all the supplied prioritisers, and if none match it, then it will +-- be assigned the lowest possible priority (i.e. put at the back of the queue). +enqueueMessage :: forall s . s + -> [DispatchPriority s] + -> Message + -> GenProcess s () +enqueueMessage s [] m' = + enqueueMessage s [ PrioritiseInfo { + prioritise = (\_ m -> + return $ Just ((-1 :: Int), m)) :: s -> Message -> Process (Maybe (Int, Message)) } ] m' +enqueueMessage s (p:ps) m' = let checkPrio = prioritise p s in do + (lift $ checkPrio m') >>= doEnqueue s ps m' + where + doEnqueue :: s + -> [DispatchPriority s] + -> Message + -> Maybe (Int, Message) + -> GenProcess s () + doEnqueue s' ps' msg Nothing = enqueueMessage s' ps' msg + doEnqueue _ _ _ (Just (i, m)) = updateQueue (Q.enqueue (i * (-1 :: Int)) m) + +-------------------------------------------------------------------------------- +-- Process Loop Implementations -- +-------------------------------------------------------------------------------- + +-- | Maps handlers to a dynamic action that can take place outside of a +-- expect/recieve block. This is used by the prioritised process loop. +class DynMessageHandler d where + dynHandleMessage :: UnhandledMessagePolicy + -> s + -> d s + -> Message + -> Process (Maybe (ProcessAction s)) + +instance DynMessageHandler Dispatcher where + dynHandleMessage _ s (Dispatch d) msg = handleMessage msg (d s) + dynHandleMessage _ s (DispatchIf d c) msg = handleMessageIf msg (c s) (d s) + +instance DynMessageHandler ExternDispatcher where + dynHandleMessage _ s (DispatchCC _ d) msg = handleMessage msg (d s) + dynHandleMessage _ s (DispatchSTM _ d _ _) msg = handleMessage msg (d s) + +instance DynMessageHandler DeferredDispatcher where + dynHandleMessage _ s (DeferredDispatcher d) = d s + +-- | Maps filters to an action that can take place outside of a +-- expect/recieve block. +class DynFilterHandler d where + dynHandleFilter :: s + -> d s + -> Message + -> Process (Maybe (Filter s)) + +instance DynFilterHandler DispatchFilter where + dynHandleFilter s (FilterApi d) msg = handleMessage msg (d s) + dynHandleFilter s (FilterAny d) msg = handleMessage msg (d s) + dynHandleFilter s (FilterRaw d) msg = d s msg + dynHandleFilter s (FilterState d) _ = d s + +-- | Prioritised process loop. +-- +-- Evaluating this function will cause the caller to enter a server loop, +-- constantly reading messages from its mailbox (and/or other supplied control +-- planes) and passing these to handler functions in the supplied process +-- definition. Only when it is determined that the server process should +-- terminate - either by the handlers deciding to stop the process, or by an +-- unhandled exit signal or other form of failure condition (e.g. synchronous or +-- asynchronous exceptions). +-- +-- ensureIOManagerIsRunning before evaluating this loop... +-- +precvLoop :: PrioritisedProcessDefinition s + -> s + -> Delay + -> Process ExitReason +precvLoop ppDef pState recvDelay = do + st <- P.liftIO $ newIORef $ ProcessState { timeoutSpec = recvTimeout ppDef + , sysTimeout = delayTimer Infinity + , usrTimeout = recvDelay + , internalQ = Q.empty + , procState = pState + , procDef = processDef ppDef + , procPrio = priorities ppDef + , procFilters = filters ppDef + , usrTimers = Map.empty + } + + mask $ \restore -> do + res <- catch (fmap Right $ restore $ loop st) + (\(e :: SomeException) -> return $ Left e) + + -- res could be (Left ex), so we restore process state & def from our IORef + ps <- P.liftIO $ atomicModifyIORef' st $ \s' -> (s', s') + let st' = procState ps + pd = procDef ps + sh = shutdownHandler pd + case res of + Right (exitReason, _) -> do + restore $ sh (CleanShutdown st') exitReason + return exitReason + Left ex -> do + -- we'll attempt to run the exit handler with the original state + restore $ sh (LastKnown st') (ExitOther $ show ex) + throwM ex + where + loop st' = catchExit (runProcess st' recvQueue) + (\_ (r :: ExitReason) -> return (r, st')) + +recvQueue :: GenProcess s ExitReason +recvQueue = do + pd <- processDefinition + let ex = trapExit:(exitHandlers $ pd) + let exHandlers = map (\d' -> (dispatchExit d')) ex + + catch (drainMailbox >> processNext >>= nextAction) + (\(e :: ProcessExitException) -> + handleExit exHandlers e >>= nextAction) + where + + handleExit :: [(s -> ProcessId -> Message -> Process (Maybe (ProcessAction s)))] + -> ProcessExitException + -> GenProcess s (ProcessAction s) + handleExit [] ex = throwM ex + handleExit (h:hs) ex@(ProcessExitException pid msg) = do + r <- processState >>= \s -> lift $ h s pid msg + case r of + Nothing -> handleExit hs ex + Just p -> return p + + nextAction :: ProcessAction s -> GenProcess s ExitReason + nextAction ac + | ProcessExpression expr <- ac = expr >>= nextAction + | ProcessActivity act' <- ac = act' >> recvQueue + | ProcessSkip <- ac = recvQueue + | ProcessContinue ps' <- ac = recvQueueAux ps' + | ProcessTimeout d ps' <- ac = setUserTimeout d >> recvQueueAux ps' + | ProcessStop xr <- ac = return xr + | ProcessStopping ps' xr <- ac = setProcessState ps' >> return xr + | ProcessHibernate d' s' <- ac = (lift $ block d') >> recvQueueAux s' + | ProcessBecome pd' ps' <- ac = do + modifyState $ \st@ProcessState{..} -> st { procDef = pd', procState = ps' } + -- liftIO $ putStrLn "modified process def" + recvQueue + | otherwise {- compiler foo -} = return $ ExitOther "IllegalState" + + recvQueueAux st = setProcessState st >> recvQueue + + -- TODO: at some point we should re-implement our state monad in terms of + -- mkWeakIORef instead of a full IORef. At that point, we can implement hiberation + -- in the following terms: + -- 1. the user defines (at some level, perhaps outside of this API) some + -- means for writing a process' state to a backing store + -- NB: this could be /persistent/, or a file, or database, etc... + -- 2. when we enter hibernation, we do the following: + -- (a) write the process state to the chosen backing store + -- (b) evaluate yield (telling the RTS we're willing to give up our time slice) + -- (c) enter a blocking receiveWait with no state on our stack... + -- [NB] presumably at this point our state will be eligible for GC + -- (d) when we finally receive a message, reboot the process thus: + -- (i) read our state back from the given backing store + -- (ii) call a user defined function to rebuild the state if custom + -- actions need to be taken (e.g. they might've stored something + -- like an STM TVar and need to request a new one from some + -- well known service or registry - alt. they might want to + -- /replay/ actions to rebuild their state as an FSM might) + -- (iii) re-enter the recv loop and immediately processNext + -- + -- This will give roughly the same semantics as erlang's hibernate/3, although + -- the RTS does GC globally rather than per-thread, but that might change in + -- some future release (who knows!?). + -- + -- Also, this gives us the ability to migrate process state across remote + -- boundaries. Not only can a process be moved in this way, if we generalise + -- the mechanism to move a serialised closure, we can migrate the whole process + -- and its state as well. The main difference here (with ordinary use of + -- @Closure@ et al for moving processes around, is that we do not insist + -- on the process state being serializable, simply that they provide a + -- function to read+write the state, and a (state -> state) function to be + -- called during rehydration if custom actions need to be taken. + -- + + processNext :: GenProcess s (ProcessAction s) + processNext = do + (up, pf) <- gets $ liftA2 (,) (unhandledMessagePolicy . procDef) procFilters + case pf of + [] -> consumeMessage + _ -> filterMessage (filterNext False up pf Nothing) + + consumeMessage = applyNext dequeue processApply + filterMessage = applyNext peek + + filterNext :: Safe + -> UnhandledMessagePolicy + -> [DispatchFilter s] + -> Maybe (Filter s) + -> Message + -> GenProcess s (ProcessAction s) + filterNext isSafe mp' fs mf msg + | Just (FilterSafe s') <- mf = filterNext True mp' fs (Just $ FilterOk s') msg + | Just (FilterSkip s') <- mf = setProcessState s' >> dequeue >> return ProcessSkip + | Just (FilterStop s' r) <- mf = return $ ProcessStopping s' r + | isSafe + , Just (FilterOk s') <- mf + , [] <- fs = do setProcessState s' + act' <- processApply msg + dequeue >> return act' + | Just (FilterOk s') <- mf + , [] <- fs = setProcessState s' >> applyNext dequeue processApply + | Nothing <- mf, [] <- fs = applyNext dequeue processApply + | Just (FilterOk s') <- mf + , (f:fs') <- fs = do + setProcessState s' + act' <- lift $ dynHandleFilter s' f msg + filterNext isSafe mp' fs' act' msg + | Just (FilterReject _ s') <- mf = do + setProcessState s' >> dequeue >>= lift . applyPolicy mp' s' . fromJust + | Nothing <- mf {- filter didn't apply to the input type -} + , (f:fs') <- fs = processState >>= \s' -> do + lift (dynHandleFilter s' f msg) >>= \a -> filterNext isSafe mp' fs' a msg + + applyNext :: (GenProcess s (Maybe Message)) + -> (Message -> GenProcess s (ProcessAction s)) + -> GenProcess s (ProcessAction s) + applyNext queueOp handler = do + next <- queueOp + case next of + Nothing -> drainOrTimeout + Just msg -> handler msg + + processApply msg = do + (def, pState) <- gets $ liftA2 (,) procDef procState + let pol = unhandledMessagePolicy def + apiMatchers = map (dynHandleMessage pol pState) (apiHandlers def) + infoMatchers = map (dynHandleMessage pol pState) (infoHandlers def) + extMatchers = map (dynHandleMessage pol pState) (externHandlers def) + shutdown' = dynHandleMessage pol pState shutdownHandler' + ms' = (shutdown':extMatchers) ++ apiMatchers ++ infoMatchers + -- liftIO $ putStrLn $ "we have " ++ (show $ (length apiMatchers, length infoMatchers)) ++ " handlers" + processApplyAux ms' pol pState msg + + processApplyAux [] p' s' m' = lift $ applyPolicy p' s' m' + processApplyAux (h:hs) p' s' m' = do + attempt <- lift $ h m' + case attempt of + Nothing -> processApplyAux hs p' s' m' + Just act' -> return act' + + drainMailbox :: GenProcess s () + drainMailbox = do + -- see note [timer handling whilst draining the process' mailbox] + ps <- processState + pd <- processDefinition + pp <- processPriorities + ut <- gets usrTimers + let ts = Map.foldrWithKey (\k (t, _) ms -> ms ++ matchKey k t) [] ut + let ms = ts ++ (matchAny (return . Right) : (mkMatchers ps pd)) + timerAcc <- timeoutPolicy >>= \spec -> case spec of + RecvTimer _ -> return Nothing + RecvMaxBacklog cnt -> return $ Just cnt + -- see note [handling async exceptions during non-blocking reads] + -- Also note that we only use the system timeout here, dropping into the + -- user timeout only if we end up in a blocking read on the mailbox. + -- + mask_ $ do + tt <- maybeStartTimer + drainAux ps pp timerAcc (ms ++ matchTimeout tt) + (lift $ stopTimer tt) >>= setDrainTimeout + + drainAux :: s + -> [DispatchPriority s] + -> Limit + -> [Match (Either TimedOut Message)] + -> GenProcess s () + drainAux ps' pp' maxbq ms = do + (cnt, m) <- scanMailbox maxbq ms + case m of + Nothing -> return () + Just (Right m') -> do enqueueMessage ps' pp' m' + drainAux ps' pp' cnt ms + Just (Left TimedOut) -> return () + Just (Left (Yield i)) -> + -- we saw a user defined timer fire, and will have an associated message... + -- this is a bit complex, we have to enqueue the message and remove the timer + -- the latter part of which is handled for us by consumeTimer + consumeTimer i push >> drainAux ps' pp' cnt ms + + maybeStartTimer :: GenProcess s Timer + maybeStartTimer = do + tp <- timeoutPolicy + t <- case tp of + RecvTimer d -> (lift $ startTimer $ Delay d) + _ -> return $ delayTimer Infinity + setDrainTimeout t + return t + + scanMailbox :: Limit + -> [Match (Either TimedOut Message)] + -> GenProcess s (Limit, Maybe (Either TimedOut Message)) + scanMailbox lim ms + | Just 0 <- lim = return (lim, Just $ Left TimedOut) + | Just c <- lim = do {- non-blocking read on our mailbox, any external inputs, + plus whatever match specs the TimeoutManager gives -} + lift $ fmap (Just (c - 1), ) (receiveTimeout 0 ms) + | otherwise = lift $ fmap (lim, ) (receiveTimeout 0 ms) + + -- see note [timer handling whilst draining the process' mailbox] + drainOrTimeout :: GenProcess s (ProcessAction s) + drainOrTimeout = do + pd <- processDefinition + ps <- processState + ud <- currentTimeout + mr <- mkMatchRunners + let ump = unhandledMessagePolicy pd + hto = timeoutHandler pd + matches = mr ++ ((matchMessage return):map (matchExtern ump ps) (externHandlers pd)) + recv = case ud of + Infinity -> lift $ fmap Just (receiveWait matches) + NoDelay -> lift $ receiveTimeout 0 matches + Delay i -> lift $ receiveTimeout (asTimeout i) matches + + -- see note [masking async exceptions during recv] + mask $ \restore -> recv >>= \r -> + case r of + Nothing -> restore $ lift $ hto ps ud + Just m -> do + pp <- processPriorities + enqueueMessage ps pp m + -- Returning @ProcessSkip@ simply causes us to go back into + -- listening mode until we hit RecvTimeoutPolicy + restore $ return ProcessSkip + + mkMatchRunners :: GenProcess s [Match Message] + mkMatchRunners = do + ut <- gets usrTimers + fn <- mkRunner + let ms = Map.foldrWithKey (\k (t, _) ms' -> ms' ++ matchRun fn k t) [] ut + return ms + + mkRunner :: GenProcess s (TimerKey -> Process Message) + mkRunner = do + st <- ST.get + let fn = \k -> do (m, _) <- runProcess st (consumeTimer k return) + return m + return fn + + mkMatchers :: s + -> ProcessDefinition s + -> [Match (Either TimedOut Message)] + mkMatchers st df = + map (matchMapExtern (unhandledMessagePolicy df) st toRight) + (externHandlers df) + + toRight :: Message -> Either TimedOut Message + toRight = Right + +-- note [handling async exceptions during non-blocking reads] +-- Our golden rule is that if we've dequeued any kind of Message at all +-- from the process mailbox (or input channels), we must not /lose/ it +-- if an asynchronous exception arrives. We therefore mask when we perform a +-- non-blocking scan on the mailbox, and whilst we enqueue messages. +-- +-- If an initial scan of the mailbox yields no data, we fall back to making +-- a blocking read; See note [masking async exceptions during recv]. +-- +-- Once messages have been safely moved from the mailbox to our priority queue, +-- we restore the masking state whilst running handlers. +-- + +-- note [timer handling whilst draining the process' mailbox] +-- To prevent a DOS vector - and quite a likely accidental one at that - we do not +-- sit draining the mailbox indefinitely, since continuous reading would thus +-- leave us unable to process any inputs and we'd eventually run out of memory. +-- Instead, the PrioritisedProcessDefinition holds a RecvTimeoutPolicy which can +-- hold either a max-messages-processed limit or a timeout value. Using whichever +-- policy is provided, drainMessageQueue will stop attempting to receive new mail +-- either once the message count limit is exceeded or the timer expires, at which +-- point we go back to processNext. + +-- note [masking async exceptions during recv] +-- Reading the process' mailbox is mask'ed anyway, however this only +-- covers dequeue on the underlying CQueue, such that either before +-- the dequeue takes place, or after (during evaluation of the result, +-- or execution of the discovered @Match@ for the message), we can still +-- be terminated by an asynchronous exception. This is wrong, from the +-- perspective of a managed process, since in the case of an exit signal +-- we might handle the exception, at which point we've dequeued and +-- subsequently lost a message. +-- +-- Masking recv then, prevents this from happening, and is relatively +-- safe, because we know the following (having written all the handlers +-- explicitly ourselves): +-- +-- 1. each handler does nothing more than return the underlying message +-- 2. in the most complex case, we have @Left . unsafeWrapMessage@ or +-- @fmap Right readSTM thing@ inside of @matchSTM@ +-- 3. We should not, therefore, introduce any uninterruptible behaviour +-- 4. We cannot, however, be certain that this holds true for decoding +-- (and subsequent calls into Binary and/or Bytestrings), so at best +-- we can mask, but not uninterruptibleMask +-- +-- NB: According to /qnikst/, atomicModifyIORef' does not require us to +-- use uninterruptibleMask anyway, so this is fine... +-- + +-------------------------------------------------------------------------------- +-- Ordinary/Blocking Mailbox Handling -- +-------------------------------------------------------------------------------- + +-- TODO: wrap recvLoop in the same exception handling as precvLoop +-- notably, we need to ensure the shutdownHandler runs even in the face +-- of exceptions, and it would be useful/good IMO to pass an IORef for +-- the state, so we can have a decent LastKnown value for it + +-- | Managed process loop. +-- +-- Evaluating this function will cause the caller to enter a server loop, +-- constantly reading messages from its mailbox (and/or other supplied control +-- planes) and passing these to handler functions in the supplied process +-- definition. Only when it is determined that the server process should +-- terminate - either by the handlers deciding to stop the process, or by an +-- unhandled exit signal or other form of failure condition (e.g. synchronous or +-- asynchronous exceptions). +-- +recvLoop :: ProcessDefinition s -> s -> Delay -> Process ExitReason +recvLoop pDef pState recvDelay = + let p = unhandledMessagePolicy pDef + handleTimeout = timeoutHandler pDef + handleStop = shutdownHandler pDef + shutdown' = matchDispatch p pState shutdownHandler' + extMatchers = map (matchDispatch p pState) (externHandlers pDef) + matchers = extMatchers ++ (map (matchDispatch p pState) (apiHandlers pDef)) + ex' = (trapExit:(exitHandlers pDef)) + ms' = (shutdown':matchers) ++ matchAux p pState (infoHandlers pDef) + in do + ac <- catchesExit (processReceive ms' handleTimeout pState recvDelay) + (map (\d' -> (dispatchExit d') pState) ex') + case ac of + ProcessSkip -> recvLoop pDef pState recvDelay -- TODO: handle differently... + (ProcessContinue s') -> recvLoop pDef s' recvDelay + (ProcessTimeout t' s') -> recvLoop pDef s' t' + (ProcessHibernate d' s') -> block d' >> recvLoop pDef s' recvDelay + (ProcessStop r) -> handleStop (LastKnown pState) r >> return (r :: ExitReason) + (ProcessStopping s' r) -> handleStop (LastKnown s') r >> return (r :: ExitReason) + (ProcessBecome d' s') -> recvLoop d' s' recvDelay + (ProcessActivity _) -> die $ "recvLoop.InvalidState - ProcessActivityNotSupported" + (ProcessExpression _) -> die $ "recvLoop.InvalidState - ProcessExpressionNotSupported" + where + matchAux :: UnhandledMessagePolicy + -> s + -> [DeferredDispatcher s] + -> [Match (ProcessAction s)] + matchAux p ps ds = [matchAny (auxHandler (applyPolicy p ps) ps ds)] + + auxHandler :: (Message -> Process (ProcessAction s)) + -> s + -> [DeferredDispatcher s] + -> Message + -> Process (ProcessAction s) + auxHandler policy _ [] msg = policy msg + auxHandler policy st (d:ds :: [DeferredDispatcher s]) msg + | length ds > 0 = let dh = dispatchInfo d in do + -- NB: we *do not* want to terminate/dead-letter messages until + -- we've exhausted all the possible info handlers + m <- dh st msg + case m of + Nothing -> auxHandler policy st ds msg + Just act' -> return act' + -- but here we *do* let the policy kick in + | otherwise = let dh = dispatchInfo d in do + m <- dh st msg + case m of + Nothing -> policy msg + Just act' -> return act' + + processReceive :: [Match (ProcessAction s)] + -> TimeoutHandler s + -> s + -> Delay + -> Process (ProcessAction s) + processReceive ms handleTimeout st d = do + next <- recv ms d + case next of + Nothing -> handleTimeout st d + Just pa -> return pa + + recv :: [Match (ProcessAction s)] + -> Delay + -> Process (Maybe (ProcessAction s)) + recv matches d' = + case d' of + Infinity -> receiveWait matches >>= return . Just + NoDelay -> receiveTimeout 0 matches + Delay t' -> receiveTimeout (asTimeout t') matches + +-------------------------------------------------------------------------------- +-- Utilities -- +-------------------------------------------------------------------------------- + +-- an explicit 'cast' giving 'Shutdown' will stop the server gracefully +shutdownHandler' :: Dispatcher s +shutdownHandler' = handleCast (\_ Shutdown -> stop $ ExitNormal) + +-- @(ProcessExitException from ExitShutdown)@ will stop the server gracefully +trapExit :: ExitSignalDispatcher s +trapExit = handleExitIf (\_ e -> e == ExitShutdown) + (\_ _ (r :: ExitReason) -> stop r) + +block :: TimeInterval -> Process () +block i = + void $ receiveTimeout (asTimeout i) [ match (\(_ :: TimedOut) -> return ()) ] + +applyPolicy :: UnhandledMessagePolicy + -> s + -> Message + -> Process (ProcessAction s) +applyPolicy p s m = + case p of + Terminate -> stop $ ExitOther "UnhandledInput" + DeadLetter pid -> forward m pid >> continue s + Drop -> continue s + Log -> logIt >> continue s + where + logIt = + Log.report Log.info Log.logChannel $ "Unhandled Gen Input Message: " ++ (show m) diff --git a/packages/distributed-process-client-server/src/Control/Distributed/Process/ManagedProcess/Internal/PriorityQueue.hs b/packages/distributed-process-client-server/src/Control/Distributed/Process/ManagedProcess/Internal/PriorityQueue.hs new file mode 100644 index 00000000..d2d05c59 --- /dev/null +++ b/packages/distributed-process-client-server/src/Control/Distributed/Process/ManagedProcess/Internal/PriorityQueue.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE BangPatterns #-} +module Control.Distributed.Process.ManagedProcess.Internal.PriorityQueue where + +-- NB: we might try this with a skewed binomial heap at some point, +-- but for now, we'll use this module from the fingertree package +import qualified Data.PriorityQueue.FingerTree as PQ +import qualified Data.Foldable as F (toList) +import Data.PriorityQueue.FingerTree (PQueue) + +newtype PriorityQ k a = PriorityQ { q :: PQueue k a } + +{-# INLINE empty #-} +empty :: Ord k => PriorityQ k v +empty = PriorityQ $ PQ.empty + +{-# INLINE isEmpty #-} +isEmpty :: Ord k => PriorityQ k v -> Bool +isEmpty = PQ.null . q + +{-# INLINE singleton #-} +singleton :: Ord k => k -> a -> PriorityQ k a +singleton !k !v = PriorityQ $ PQ.singleton k v + +{-# INLINE enqueue #-} +enqueue :: Ord k => k -> v -> PriorityQ k v -> PriorityQ k v +enqueue !k !v p = PriorityQ (PQ.add k v $ q p) + +{-# INLINE dequeue #-} +dequeue :: Ord k => PriorityQ k v -> Maybe (v, PriorityQ k v) +dequeue p = maybe Nothing (\(v, pq') -> Just (v, pq')) $ + case (PQ.minView (q p)) of + Nothing -> Nothing + Just (v, q') -> Just (v, PriorityQ $ q') + +{-# INLINE peek #-} +peek :: Ord k => PriorityQ k v -> Maybe v +peek p = maybe Nothing (\(v, _) -> Just v) $ dequeue p + +{-# INLINE toList #-} +toList :: Ord k => PriorityQ k a -> [a] +toList = F.toList . q diff --git a/packages/distributed-process-client-server/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs b/packages/distributed-process-client-server/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs new file mode 100644 index 00000000..f908c763 --- /dev/null +++ b/packages/distributed-process-client-server/src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs @@ -0,0 +1,694 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LiberalTypeSynonyms #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} + +-- | Types used throughout the ManagedProcess framework +module Control.Distributed.Process.ManagedProcess.Internal.Types + ( -- * Exported data types + InitResult(..) + , GenProcess() + , runProcess + , lift + , liftIO + , ProcessState(..) + , State + , Queue + , Limit + , Condition(..) + , ProcessAction(..) + , ProcessReply(..) + , Action + , Reply + , ActionHandler + , CallHandler + , CastHandler + , StatelessHandler + , DeferredCallHandler + , StatelessCallHandler + , InfoHandler + , ChannelHandler + , StatelessChannelHandler + , InitHandler + , ShutdownHandler + , ExitState(..) + , isCleanShutdown + , exitState + , TimeoutHandler + , UnhandledMessagePolicy(..) + , ProcessDefinition(..) + , Priority(..) + , DispatchPriority(..) + , DispatchFilter(..) + , Filter(..) +-- , Check(..) + , PrioritisedProcessDefinition(..) + , RecvTimeoutPolicy(..) + , ControlChannel(..) + , newControlChan + , ControlPort(..) + , channelControlPort + , Dispatcher(..) + , ExternDispatcher(..) + , DeferredDispatcher(..) + , ExitSignalDispatcher(..) + , MessageMatcher(..) + , ExternMatcher(..) + , Message(..) + , CallResponse(..) + , CallId + , CallRef(..) + , CallRejected(..) + , makeRef + , caller + , rejectToCaller + , recipient + , tag + , initCall + , unsafeInitCall + , waitResponse + ) where + +import Control.Concurrent.STM (STM) +import Control.Distributed.Process hiding (Message, mask, finally, liftIO) +import qualified Control.Distributed.Process as P (Message, liftIO) +import Control.Distributed.Process.Serializable +import Control.Distributed.Process.Extras + ( Recipient(..) + , ExitReason(..) + , Addressable + , Resolvable(..) + , Routable(..) + , NFSerializable + ) +import Control.Distributed.Process.ManagedProcess.Internal.PriorityQueue + ( PriorityQ + ) +import Control.Distributed.Process.Extras.Internal.Types + ( resolveOrDie + ) +import Control.Distributed.Process.Extras.Time +import Control.Distributed.Process.ManagedProcess.Timer (Timer, TimerKey) +import Control.DeepSeq (NFData(..)) +import Control.Monad.Fix (MonadFix) +import Control.Monad.Catch + ( catch + , throwM + , uninterruptibleMask + , mask + , finally + , MonadThrow + , MonadCatch + , MonadMask(..) + ) +import qualified Control.Monad.Catch as Catch + ( catch + , throwM + ) +import Control.Monad.IO.Class (MonadIO) +import qualified Control.Monad.State.Strict as ST + ( MonadState + , StateT + , get + , lift + , runStateT + ) +import Data.Binary hiding (decode) +import Data.Map.Strict (Map) +import Data.Typeable (Typeable) +import Data.IORef (IORef) +import Prelude hiding (init) +import GHC.Generics + +-------------------------------------------------------------------------------- +-- API -- +-------------------------------------------------------------------------------- + +-- | wrapper for a @MonitorRef@ +type CallId = MonitorRef + +-- | Wraps a consumer of the call API +newtype CallRef a = CallRef { unCaller :: (Recipient, CallId) } + deriving (Eq, Show, Typeable, Generic) + +-- | Retrieve the @Recipient@ for a @CallRef@. +recipient :: CallRef a -> Recipient +recipient = fst . unCaller + +-- | Retrieve the @CallId@ for a @CallRef@. +tag :: CallRef a -> CallId +tag = snd . unCaller + +instance Binary (CallRef a) where +instance NFData (CallRef a) where rnf (CallRef x) = rnf x `seq` () + +-- | Creates a @CallRef@ for the given @Recipient@ and @CallId@ +makeRef :: Recipient -> CallId -> CallRef a +makeRef r c = CallRef (r, c) + +-- | @Message@ type used internally by the call, cast, and rpcChan APIs. +data Message a b = + CastMessage a + | CallMessage a (CallRef b) + | ChanMessage a (SendPort b) + deriving (Typeable, Generic) + +-- | Retrieve the @Recipient@ from a @Message@. If the supplied message is +-- a /cast/ or /chan/ message will evaluate to @Nothing@, otherwise @Just ref@. +caller :: forall a b . Message a b -> Maybe Recipient +caller (CallMessage _ ref) = Just $ recipient ref +caller _ = Nothing + +-- | Reject a /call/ message with the supplied string. Sends @CallRejected@ to +-- the recipient if the input is a @CallMessage@, otherwise has no side effects. +rejectToCaller :: forall a b . + Message a b -> String -> Process () +rejectToCaller (CallMessage _ ref) m = sendTo ref (CallRejected m (tag ref)) +rejectToCaller _ _ = return () + +instance (Serializable a, Serializable b) => Binary (Message a b) where +instance (NFSerializable a, NFSerializable b) => NFData (Message a b) where + rnf (CastMessage a) = rnf a `seq` () + rnf (CallMessage a b) = rnf a `seq` rnf b `seq` () + rnf (ChanMessage a b) = rnf a `seq` rnf b `seq` () +deriving instance (Eq a, Eq b) => Eq (Message a b) +deriving instance (Show a, Show b) => Show (Message a b) + +-- | Response type for the call API +data CallResponse a = CallResponse a CallId + deriving (Typeable, Generic) + +instance Serializable a => Binary (CallResponse a) +instance NFSerializable a => NFData (CallResponse a) where + rnf (CallResponse a c) = rnf a `seq` rnf c `seq` () +deriving instance Eq a => Eq (CallResponse a) +deriving instance Show a => Show (CallResponse a) + +-- | Sent to a consumer of the /call/ API when a server filter expression +-- explicitly rejects an incoming call message. +data CallRejected = CallRejected String CallId + deriving (Typeable, Generic, Show, Eq) +instance Binary CallRejected where +instance NFData CallRejected where + +instance Resolvable (CallRef a) where + resolve (CallRef (r, _)) = resolve r + +instance Routable (CallRef a) where + sendTo (CallRef (c, _)) = sendTo c + unsafeSendTo (CallRef (c, _)) = unsafeSendTo c + +-- | Return type for and 'InitHandler' expression. +data InitResult s = + InitOk s Delay {- + ^ a successful initialisation, initial state and timeout -} + | InitStop String {- + ^ failed initialisation and the reason, this will result in an error -} + | InitIgnore {- + ^ the process has decided not to continue starting - this is not an error -} + deriving (Typeable) + +-- | Represent a max-backlog from RecvTimeoutPolicy +type Limit = Maybe Int + +-- | Internal priority queue, used by prioritised processes. +type Queue = PriorityQ Int P.Message + +-- | Map from @TimerKey@ to @(Timer, Message)@. +type TimerMap = Map TimerKey (Timer, P.Message) + +-- | Internal state of a prioritised process loop. +data ProcessState s = ProcessState { timeoutSpec :: RecvTimeoutPolicy + , procDef :: ProcessDefinition s + , procPrio :: [DispatchPriority s] + , procFilters :: [DispatchFilter s] + , usrTimeout :: Delay + , sysTimeout :: Timer + , usrTimers :: TimerMap + , internalQ :: Queue + , procState :: s + } + +-- | Prioritised process state, held as an @IORef@. +type State s = IORef (ProcessState s) + +-- | StateT based monad for prioritised process loops. +newtype GenProcess s a = GenProcess { + unManaged :: ST.StateT (State s) Process a + } + deriving ( Functor + , Monad + , ST.MonadState (State s) + , MonadIO + , MonadFix + , Typeable + , Applicative + ) + +instance forall s . MonadThrow (GenProcess s) where + throwM = lift . Catch.throwM + +instance forall s . MonadCatch (GenProcess s) where + catch p h = do + pSt <- ST.get + -- we can throw away our state since it is always accessed via an IORef + (a, _) <- lift $ Catch.catch (runProcess pSt p) (runProcess pSt . h) + return a + +instance forall s . MonadMask (GenProcess s) where + mask p = do + pSt <- ST.get + lift $ mask $ \restore -> do + (a, _) <- runProcess pSt (p (liftRestore restore)) + return a + where + liftRestore restoreP = \p2 -> do + ourSTate <- ST.get + (a', _) <- lift $ restoreP $ runProcess ourSTate p2 + return a' + + uninterruptibleMask p = do + pSt <- ST.get + (a, _) <- lift $ uninterruptibleMask $ \restore -> + runProcess pSt (p (liftRestore restore)) + return a + where + liftRestore restoreP = \p2 -> do + ourSTate <- ST.get + (a', _) <- lift $ restoreP $ runProcess ourSTate p2 + return a' + + generalBracket acquire release inner = GenProcess $ + generalBracket (unManaged acquire) + (\a e -> unManaged $ release a e) + (unManaged . inner) + +-- | Run an action in the @GenProcess@ monad. +runProcess :: State s -> GenProcess s a -> Process (a, State s) +runProcess state proc = ST.runStateT (unManaged proc) state + +-- | Lift an action in the @Process@ monad to @GenProcess@. +lift :: Process a -> GenProcess s a +lift p = GenProcess $ ST.lift p + +-- | Lift an IO action directly into @GenProcess@, @liftIO = lift . Process.LiftIO@. +liftIO :: IO a -> GenProcess s a +liftIO = lift . P.liftIO + +-- | The action taken by a process after a handler has run and its updated state. +-- See "Control.Distributed.Process.ManagedProcess.Server.continue" +-- "Control.Distributed.Process.ManagedProcess.Server.timeoutAfter" +-- "Control.Distributed.Process.ManagedProcess.Server.hibernate" +-- "Control.Distributed.Process.ManagedProcess.Server.stop" +-- "Control.Distributed.Process.ManagedProcess.Server.stopWith" +-- +-- Also see "Control.Distributed.Process.Management.Priority.act" and +-- "Control.Distributed.Process.ManagedProcess.Priority.runAfter". +-- +-- And other actions. This type should not be used directly. +data ProcessAction s = + ProcessSkip + | ProcessActivity (GenProcess s ()) -- ^ run the given activity + | ProcessExpression (GenProcess s (ProcessAction s)) -- ^ evaluate an expression + | ProcessContinue s -- ^ continue with (possibly new) state + | ProcessTimeout Delay s -- ^ timeout if no messages are received + | ProcessHibernate TimeInterval s -- ^ hibernate for /delay/ + | ProcessStop ExitReason -- ^ stop the process, giving @ExitReason@ + | ProcessStopping s ExitReason -- ^ stop the process with @ExitReason@, with updated state + | ProcessBecome (ProcessDefinition s) s -- ^ changes the current process definition + +-- | Returned from handlers for the synchronous 'call' protocol, encapsulates +-- the reply data /and/ the action to take after sending the reply. A handler +-- can return @NoReply@ if they wish to ignore the call. +data ProcessReply r s = + ProcessReply r (ProcessAction s) + | ProcessReject String (ProcessAction s) -- TODO: can we use a functional dependency here? + | NoReply (ProcessAction s) + +-- | Wraps a predicate that is used to determine whether or not a handler +-- is valid based on some combination of the current process state, the +-- type and/or value of the input message or both. +data Condition s m = + Condition (s -> m -> Bool) -- ^ predicated on the process state /and/ the message + | State (s -> Bool) -- ^ predicated on the process state only + | Input (m -> Bool) -- ^ predicated on the input message only + +{- + +class Check c s m | s m -> c where + -- data Checker c :: * -> * -> * + -- apply :: s -> m -> Checker c s m -> Bool + apply :: s -> m -> c -> Bool + +instance Check (Condition s m) s m where + -- data Checker (Condition s m) s m = CheckCond (Condition s m) + apply s m (Condition f) = f s m + apply s _ (State f) = f s + apply _ m (Input f) = f m + +instance Check (s -> m -> Bool) s m where + -- data Checker (s -> m -> Bool) s m = CheckF (s -> m -> Bool) + apply s m f = f s m +-} + +-- | Informs a /shutdown handler/ of whether it is running due to a clean +-- shutdown, or in response to an unhandled exception. +data ExitState s = CleanShutdown s -- ^ given when an ordered shutdown is underway + | LastKnown s {- + ^ given due to an unhandled exception, passing the last known state -} + +-- | @True@ if the @ExitState@ is @CleanShutdown@, otherwise @False@. +isCleanShutdown :: ExitState s -> Bool +isCleanShutdown (CleanShutdown _) = True +isCleanShutdown _ = False + +-- | Evaluates to the @s@ state datum in the given @ExitState@. +exitState :: ExitState s -> s +exitState (CleanShutdown s) = s +exitState (LastKnown s) = s + +-- | An action (server state transition) in the @Process@ monad +type Action s = Process (ProcessAction s) + +-- | An action (server state transition) causing a reply to a caller, in the +-- @Process@ monad +type Reply b s = Process (ProcessReply b s) + +-- | An expression used to handle a message +type ActionHandler s a = s -> a -> Action s + +-- | An expression used to handle a message and providing a reply +type CallHandler s a b = s -> a -> Reply b s + +-- | An expression used to ignore server state during handling +type StatelessHandler s a = a -> (s -> Action s) + +-- | An expression used to handle a /call/ message where the reply is deferred +-- via the 'CallRef' +type DeferredCallHandler s a b = CallRef b -> CallHandler s a b + +-- | An expression used to handle a /call/ message ignoring server state +type StatelessCallHandler s a b = CallRef b -> a -> Reply b s + +-- | An expression used to handle a /cast/ message +type CastHandler s a = ActionHandler s a + +-- | An expression used to handle an /info/ message +type InfoHandler s a = ActionHandler s a + +-- | An expression used to handle a /channel/ message +type ChannelHandler s a b = SendPort b -> ActionHandler s a + +-- | An expression used to handle a /channel/ message in a stateless process +type StatelessChannelHandler s a b = SendPort b -> StatelessHandler s a + +-- | An expression used to initialise a process with its state +type InitHandler a s = a -> Process (InitResult s) + +-- | An expression used to handle process termination +type ShutdownHandler s = ExitState s -> ExitReason -> Process () + +-- | An expression used to handle process timeouts +type TimeoutHandler s = ActionHandler s Delay + +-- dispatching to implementation callbacks + +-- | Provides a means for servers to listen on a separate, typed /control/ +-- channel, thereby segregating the channel from their regular +-- (and potentially busy) mailbox. +newtype ControlChannel m = + ControlChannel { + unControl :: (SendPort (Message m ()), ReceivePort (Message m ())) + } + +-- | Creates a new 'ControlChannel'. +newControlChan :: (Serializable m) => Process (ControlChannel m) +newControlChan = fmap ControlChannel newChan + +-- | The writable end of a 'ControlChannel'. +-- +newtype ControlPort m = + ControlPort { + unPort :: SendPort (Message m ()) + } deriving (Show) +deriving instance (Serializable m) => Binary (ControlPort m) +instance Eq (ControlPort m) where + a == b = unPort a == unPort b + +-- | Obtain an opaque expression for communicating with a 'ControlChannel'. +-- +channelControlPort :: ControlChannel m + -> ControlPort m +channelControlPort cc = ControlPort $ fst $ unControl cc + +-- | Given as the result of evaluating a "DispatchFilter". This type is intended +-- for internal use. For an API for working with filters, +-- see "Control.Distributed.Process.ManagedProcess.Priority". +data Filter s = FilterOk s + | FilterSafe s + | forall m . (Show m) => FilterReject m s + | FilterSkip s + | FilterStop s ExitReason + +-- | Provides dispatch from a variety of inputs to a typed filter handler. +data DispatchFilter s = + forall a b . (Serializable a, Serializable b) => + FilterApi + { + apiFilter :: s -> Message a b -> Process (Filter s) + } + | forall a . (Serializable a) => + FilterAny + { + anyFilter :: s -> a -> Process (Filter s) + } + | FilterRaw + { + rawFilter :: s -> P.Message -> Process (Maybe (Filter s)) + } + | FilterState + { + stateFilter :: s -> Process (Maybe (Filter s)) + } + +-- | Provides dispatch from cast and call messages to a typed handler. +data Dispatcher s = + forall a b . (Serializable a, Serializable b) => + Dispatch + { + dispatch :: s -> Message a b -> Process (ProcessAction s) + } + | forall a b . (Serializable a, Serializable b) => + DispatchIf + { + dispatch :: s -> Message a b -> Process (ProcessAction s) + , dispatchIf :: s -> Message a b -> Bool + } + +-- | Provides dispatch for channels and STM actions +data ExternDispatcher s = + forall a b . (Serializable a, Serializable b) => + DispatchCC -- control channel dispatch + { + channel :: ReceivePort (Message a b) + , dispatchChan :: s -> Message a b -> Process (ProcessAction s) + } + | forall a . (Serializable a) => + DispatchSTM -- arbitrary STM actions + { + stmAction :: STM a + , dispatchStm :: s -> a -> Process (ProcessAction s) + , matchStm :: Match P.Message + , matchAnyStm :: forall m . (P.Message -> m) -> Match m + } + +-- | Provides dispatch for any input, returns 'Nothing' for unhandled messages. +data DeferredDispatcher s = + DeferredDispatcher + { + dispatchInfo :: s + -> P.Message + -> Process (Maybe (ProcessAction s)) + } + +-- | Provides dispatch for any exit signal - returns 'Nothing' for unhandled exceptions +data ExitSignalDispatcher s = + ExitSignalDispatcher + { + dispatchExit :: s + -> ProcessId + -> P.Message + -> Process (Maybe (ProcessAction s)) + } + +-- | Defines the means of dispatching inbound messages to a handler +class MessageMatcher d where + matchDispatch :: UnhandledMessagePolicy -> s -> d s -> Match (ProcessAction s) + +instance MessageMatcher Dispatcher where + matchDispatch _ s (Dispatch d) = match (d s) + matchDispatch _ s (DispatchIf d cond) = matchIf (cond s) (d s) + +instance MessageMatcher ExternDispatcher where + matchDispatch _ s (DispatchCC c d) = matchChan c (d s) + matchDispatch _ s (DispatchSTM c d _ _) = matchSTM c (d s) + +-- | Defines the means of dispatching messages from external channels (e.g. +-- those defined in terms of "ControlChannel", and STM actions) to a handler. +class ExternMatcher d where + matchExtern :: UnhandledMessagePolicy -> s -> d s -> Match P.Message + + matchMapExtern :: forall m s . UnhandledMessagePolicy + -> s -> (P.Message -> m) -> d s -> Match m + +instance ExternMatcher ExternDispatcher where + matchExtern _ _ (DispatchCC c _) = matchChan c (return . unsafeWrapMessage) + matchExtern _ _ (DispatchSTM _ _ m _) = m + + matchMapExtern _ _ f (DispatchCC c _) = matchChan c (return . f . unsafeWrapMessage) + matchMapExtern _ _ f (DispatchSTM _ _ _ p) = p f + +-- | Priority of a message, encoded as an @Int@ +newtype Priority a = Priority { getPrio :: Int } + +-- | Dispatcher for prioritised handlers +data DispatchPriority s = + PrioritiseCall + { + prioritise :: s -> P.Message -> Process (Maybe (Int, P.Message)) + } + | PrioritiseCast + { + prioritise :: s -> P.Message -> Process (Maybe (Int, P.Message)) + } + | PrioritiseInfo + { + prioritise :: s -> P.Message -> Process (Maybe (Int, P.Message)) + } + +-- | For a 'PrioritisedProcessDefinition', this policy determines for how long +-- the /receive loop/ should continue draining the process' mailbox before +-- processing its received mail (in priority order). +-- +-- If a prioritised /managed process/ is receiving a lot of messages (into its +-- /real/ mailbox), the server might never get around to actually processing its +-- inputs. This (mandatory) policy provides a guarantee that eventually (i.e., +-- after a specified number of received messages or time interval), the server +-- will stop removing messages from its mailbox and process those it has already +-- received. +-- +data RecvTimeoutPolicy = RecvMaxBacklog Int | RecvTimer TimeInterval + deriving (Typeable) + +-- | A @ProcessDefinition@ decorated with @DispatchPriority@ for certain +-- input domains. +data PrioritisedProcessDefinition s = + PrioritisedProcessDefinition + { + processDef :: ProcessDefinition s + , priorities :: [DispatchPriority s] + , filters :: [DispatchFilter s] + , recvTimeout :: RecvTimeoutPolicy + } + +-- | Policy for handling unexpected messages, i.e., messages which are not +-- sent using the 'call' or 'cast' APIs, and which are not handled by any of the +-- 'handleInfo' handlers. +data UnhandledMessagePolicy = + Terminate -- ^ stop immediately, giving @ExitOther "UnhandledInput"@ as the reason + | DeadLetter ProcessId -- ^ forward the message to the given recipient + | Log -- ^ log messages, then behave identically to @Drop@ + | Drop -- ^ dequeue and then drop/ignore the message + deriving (Show, Eq) + +-- | Stores the functions that determine runtime behaviour in response to +-- incoming messages and a policy for responding to unhandled messages. +data ProcessDefinition s = ProcessDefinition { + apiHandlers :: [Dispatcher s] -- ^ functions that handle call/cast messages + , infoHandlers :: [DeferredDispatcher s] -- ^ functions that handle non call/cast messages + , externHandlers :: [ExternDispatcher s] -- ^ functions that handle control channel and STM inputs + , exitHandlers :: [ExitSignalDispatcher s] -- ^ functions that handle exit signals + , timeoutHandler :: TimeoutHandler s -- ^ a function that handles timeouts + , shutdownHandler :: ShutdownHandler s -- ^ a function that is run just before the process exits + , unhandledMessagePolicy :: UnhandledMessagePolicy -- ^ how to deal with unhandled messages + } + +-- note [rpc calls] +-- One problem with using plain expect/receive primitives to perform a +-- synchronous (round trip) call is that a reply matching the expected type +-- could come from anywhere! The Call.hs module uses a unique integer tag to +-- distinguish between inputs but this is easy to forge, and forces all callers +-- to maintain a tag pool, which is quite onerous. +-- +-- Here, we use a private (internal) tag based on a 'MonitorRef', which is +-- guaranteed to be unique per calling process (in the absence of mallicious +-- peers). This is handled throughout the roundtrip, such that the reply will +-- either contain the CallId (i.e., the ame 'MonitorRef' with which we're +-- tracking the server process) or we'll see the server die. +-- +-- Of course, the downside to all this is that the monitoring and receiving +-- clutters up your mailbox, and if your mailbox is extremely full, could +-- incur delays in delivery. The callAsync function provides a neat +-- work-around for that, relying on the insulation provided by Async. + +-- TODO: Generify this /call/ API and use it in Call.hs to avoid tagging + +-- TODO: the code below should be moved elsewhere. Maybe to Client.hs? + +-- | The send part of the /call/ client-server interaction. The resulting +-- "CallRef" can be used to identify the corrolary response message (if one is +-- sent by the server), and is unique to this /call-reply/ pair. +initCall :: forall s a b . (Addressable s, Serializable a, Serializable b) + => s -> a -> Process (CallRef b) +initCall sid msg = do + pid <- resolveOrDie sid "initCall: unresolveable address " + mRef <- monitor pid + self <- getSelfPid + let cRef = makeRef (Pid self) mRef in do + sendTo pid (CallMessage msg cRef :: Message a b) + return cRef + +-- | Version of @initCall@ that utilises "unsafeSendTo". +unsafeInitCall :: forall s a b . ( Addressable s + , NFSerializable a + , NFSerializable b + ) + => s -> a -> Process (CallRef b) +unsafeInitCall sid msg = do + pid <- resolveOrDie sid "unsafeInitCall: unresolveable address " + mRef <- monitor pid + self <- getSelfPid + let cRef = makeRef (Pid self) mRef in do + unsafeSendTo pid (CallMessage msg cRef :: Message a b) + return cRef + +-- | Wait on the server's response after an "initCall" has been previously been sent. +-- +-- This function does /not/ trap asynchronous exceptions. +waitResponse :: forall b. (Serializable b) + => Maybe TimeInterval + -> CallRef b + -> Process (Maybe (Either ExitReason b)) +waitResponse mTimeout cRef = + let (_, mRef) = unCaller cRef + matchers = [ matchIf (\((CallResponse _ ref) :: CallResponse b) -> ref == mRef) + (\((CallResponse m _) :: CallResponse b) -> return (Right m)) + , matchIf (\((CallRejected _ ref)) -> ref == mRef) + (\(CallRejected s _) -> return (Left $ ExitOther $ s)) + , matchIf (\(ProcessMonitorNotification ref _ _) -> ref == mRef) + (\(ProcessMonitorNotification _ _ r) -> return (Left (err r))) + ] + err r = ExitOther $ show r in + case mTimeout of + (Just ti) -> finally (receiveTimeout (asTimeout ti) matchers) (unmonitor mRef) + Nothing -> finally (fmap Just (receiveWait matchers)) (unmonitor mRef) diff --git a/packages/distributed-process-client-server/src/Control/Distributed/Process/ManagedProcess/Server.hs b/packages/distributed-process-client-server/src/Control/Distributed/Process/ManagedProcess/Server.hs new file mode 100644 index 00000000..39d48daa --- /dev/null +++ b/packages/distributed-process-client-server/src/Control/Distributed/Process/ManagedProcess/Server.hs @@ -0,0 +1,671 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE PatternGuards #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Distributed.Process.ManagedProcess.Server +-- Copyright : (c) Tim Watson 2012 - 2017 +-- License : BSD3 (see the file LICENSE) +-- +-- Maintainer : Tim Watson +-- Stability : experimental +-- Portability : non-portable (requires concurrency) +-- +-- The Server Portion of the /Managed Process/ API. +----------------------------------------------------------------------------- + +module Control.Distributed.Process.ManagedProcess.Server + ( -- * Server actions + condition + , state + , input + , reply + , replyWith + , noReply + , continue + , timeoutAfter + , hibernate + , stop + , stopWith + , replyTo + , replyChan + , reject + , rejectWith + , become + -- * Stateless actions + , noReply_ + , haltNoReply_ + , continue_ + , timeoutAfter_ + , hibernate_ + , stop_ + -- * Server handler/callback creation + , handleCall + , handleCallIf + , handleCallFrom + , handleCallFromIf + , handleRpcChan + , handleRpcChanIf + , handleCast + , handleCastIf + , handleInfo + , handleRaw + , handleDispatch + , handleDispatchIf + , handleExit + , handleExitIf + -- * Stateless handlers + , action + , handleCall_ + , handleCallIf_ + , handleCallFrom_ + , handleCallFromIf_ + , handleRpcChan_ + , handleRpcChanIf_ + , handleCast_ + , handleCastIf_ + -- * Working with Control Channels + , handleControlChan + , handleControlChan_ + -- * Working with external/STM actions + , handleExternal + , handleExternal_ + , handleCallExternal + ) where + +import Control.Concurrent.STM (STM, atomically) +import Control.Distributed.Process hiding (call, Message) +import qualified Control.Distributed.Process as P (Message) +import Control.Distributed.Process.Serializable +import Control.Distributed.Process.ManagedProcess.Internal.Types hiding (liftIO, lift) +import Control.Distributed.Process.Extras + ( ExitReason(..) + , Routable(..) + ) +import Control.Distributed.Process.Extras.Time +import Prelude hiding (init) + +-------------------------------------------------------------------------------- +-- Producing ProcessAction and ProcessReply from inside handler expressions -- +-------------------------------------------------------------------------------- + +-- note [Message type]: Since we own both client and server portions of the +-- codebase, we know for certain which types will be passed to which kinds +-- of handler, so the catch-all cases that @die $ "THIS_CAN_NEVER_HAPPEN"@ and +-- such, are relatively sane despite appearances! + +-- | Creates a 'Condition' from a function that takes a process state @a@ and +-- an input message @b@ and returns a 'Bool' indicating whether the associated +-- handler should run. +-- +condition :: forall a b. (Serializable a, Serializable b) + => (a -> b -> Bool) + -> Condition a b +condition = Condition + +-- | Create a 'Condition' from a function that takes a process state @a@ and +-- returns a 'Bool' indicating whether the associated handler should run. +-- +state :: forall s m. (Serializable m) => (s -> Bool) -> Condition s m +state = State + +-- | Creates a 'Condition' from a function that takes an input message @m@ and +-- returns a 'Bool' indicating whether the associated handler should run. +-- +input :: forall s m. (Serializable m) => (m -> Bool) -> Condition s m +input = Input + +-- | Reject the message we're currently handling. +reject :: forall r s . s -> String -> Reply r s +reject st rs = continue st >>= return . ProcessReject rs + +-- | Reject the message we're currently handling, giving an explicit reason. +rejectWith :: forall r m s . (Show r) => s -> r -> Reply m s +rejectWith st rs = reject st (show rs) + +-- | Instructs the process to send a reply and continue running. +reply :: (Serializable r) => r -> s -> Reply r s +reply r s = continue s >>= replyWith r + +-- | Instructs the process to send a reply /and/ evaluate the 'ProcessAction'. +replyWith :: (Serializable r) + => r + -> ProcessAction s + -> Reply r s +replyWith r s = return $ ProcessReply r s + +-- | Instructs the process to skip sending a reply /and/ evaluate a 'ProcessAction' +noReply :: (Serializable r) => ProcessAction s -> Reply r s +noReply = return . NoReply + +-- | Continue without giving a reply to the caller - equivalent to 'continue', +-- but usable in a callback passed to the 'handleCall' family of functions. +noReply_ :: forall s r . (Serializable r) => s -> Reply r s +noReply_ s = continue s >>= noReply + +-- | Halt process execution during a call handler, without paying any attention +-- to the expected return type. +haltNoReply_ :: Serializable r => ExitReason -> Reply r s +haltNoReply_ r = stop r >>= noReply + +-- | Instructs the process to continue running and receiving messages. +continue :: s -> Action s +continue = return . ProcessContinue + +-- | Version of 'continue' that can be used in handlers that ignore process state. +-- +continue_ :: (s -> Action s) +continue_ = return . ProcessContinue + +-- | Instructs the process loop to wait for incoming messages until 'Delay' +-- is exceeded. If no messages are handled during this period, the /timeout/ +-- handler will be called. Note that this alters the process timeout permanently +-- such that the given @Delay@ will remain in use until changed. +-- +-- Note that @timeoutAfter NoDelay@ will cause the timeout handler to execute +-- immediately if no messages are present in the process' mailbox. +-- +timeoutAfter :: Delay -> s -> Action s +timeoutAfter d s = return $ ProcessTimeout d s + +-- | Version of 'timeoutAfter' that can be used in handlers that ignore process state. +-- +-- > action (\(TimeoutPlease duration) -> timeoutAfter_ duration) +-- +timeoutAfter_ :: StatelessHandler s Delay +timeoutAfter_ d = return . ProcessTimeout d + +-- | Instructs the process to /hibernate/ for the given 'TimeInterval'. Note +-- that no messages will be removed from the mailbox until after hibernation has +-- ceased. This is equivalent to calling @threadDelay@. +-- +hibernate :: TimeInterval -> s -> Process (ProcessAction s) +hibernate d s = return $ ProcessHibernate d s + +-- | Version of 'hibernate' that can be used in handlers that ignore process state. +-- +-- > action (\(HibernatePlease delay) -> hibernate_ delay) +-- +hibernate_ :: StatelessHandler s TimeInterval +hibernate_ d = return . ProcessHibernate d + +-- | The server loop will execute against the supplied 'ProcessDefinition', allowing +-- the process to change its behaviour (in terms of message handlers, exit handling, +-- termination, unhandled message policy, etc) +become :: forall s . ProcessDefinition s -> s -> Action s +become def st = return $ ProcessBecome def st + +-- | Instructs the process to terminate, giving the supplied reason. If a valid +-- 'shutdownHandler' is installed, it will be called with the 'ExitReason' +-- returned from this call, along with the process state. +stop :: ExitReason -> Action s +stop r = return $ ProcessStop r + +-- | As 'stop', but provides an updated state for the shutdown handler. +stopWith :: s -> ExitReason -> Action s +stopWith s r = return $ ProcessStopping s r + +-- | Version of 'stop' that can be used in handlers that ignore process state. +-- +-- > action (\ClientError -> stop_ ExitNormal) +-- +stop_ :: StatelessHandler s ExitReason +stop_ r _ = stop r + +-- | Sends a reply explicitly to a caller. +-- +-- > replyTo = sendTo +-- +replyTo :: (Serializable m) => CallRef m -> m -> Process () +replyTo cRef@(CallRef (_, tag)) msg = sendTo cRef $ CallResponse msg tag + +-- | Sends a reply to a 'SendPort' (for use in 'handleRpcChan' et al). +-- +-- > replyChan = sendChan +-- +replyChan :: (Serializable m) => SendPort m -> m -> Process () +replyChan = sendChan + +-------------------------------------------------------------------------------- +-- Wrapping handler expressions in Dispatcher and DeferredDispatcher -- +-------------------------------------------------------------------------------- + +-- | Constructs a 'call' handler from a function in the 'Process' monad. +-- The handler expression returns the reply, and the action will be +-- set to 'continue'. +-- +-- > handleCall_ = handleCallIf_ $ input (const True) +-- +handleCall_ :: (Serializable a, Serializable b) + => (a -> Process b) + -> Dispatcher s +handleCall_ = handleCallIf_ $ input (const True) + +-- | Constructs a 'call' handler from an ordinary function in the 'Process' +-- monad. This variant ignores the state argument present in 'handleCall' and +-- 'handleCallIf' and is therefore useful in a stateless server. Messges are +-- only dispatched to the handler if the supplied condition evaluates to @True@ +-- +-- See 'handleCall' +handleCallIf_ :: forall s a b . (Serializable a, Serializable b) + => Condition s a -- ^ predicate that must be satisfied for the handler to run + -> (a -> Process b) -- ^ a function from an input message to a reply + -> Dispatcher s +handleCallIf_ cond handler + = DispatchIf { + dispatch = \s (CallMessage p c) -> handler p >>= mkCallReply c s + , dispatchIf = checkCall cond + } + where + -- handling 'reply-to' in the main process loop is awkward at best, + -- so we handle it here instead and return the 'action' to the loop + mkCallReply :: (Serializable b) + => CallRef b + -> s + -> b + -> Process (ProcessAction s) + mkCallReply c s m = + let (c', t) = unCaller c + in sendTo c' (CallResponse m t) >> continue s + +-- | Constructs a 'call' handler from a function in the 'Process' monad. +-- > handleCall = handleCallIf (const True) +-- +handleCall :: (Serializable a, Serializable b) + => CallHandler s a b + -> Dispatcher s +handleCall = handleCallIf $ state (const True) + +-- | Constructs a 'call' handler from an ordinary function in the 'Process' +-- monad. Given a function @f :: (s -> a -> Process (ProcessReply b s))@, +-- the expression @handleCall f@ will yield a "Dispatcher" for inclusion +-- in a 'Behaviour' specification for the /GenProcess/. Messages are only +-- dispatched to the handler if the supplied condition evaluates to @True@. +-- +handleCallIf :: forall s a b . (Serializable a, Serializable b) + => Condition s a -- ^ predicate that must be satisfied for the handler to run + -> CallHandler s a b + -- ^ a reply yielding function over the process state and input message + -> Dispatcher s +handleCallIf cond handler + = DispatchIf + { dispatch = \s (CallMessage p c) -> handler s p >>= mkReply c + , dispatchIf = checkCall cond + } + +-- | A variant of 'handleCallFrom_' that ignores the state argument. +-- +handleCallFrom_ :: forall s a b . (Serializable a, Serializable b) + => StatelessCallHandler s a b + -> Dispatcher s +handleCallFrom_ = handleCallFromIf_ $ input (const True) + +-- | A variant of 'handleCallFromIf' that ignores the state argument. +-- +handleCallFromIf_ :: forall s a b . (Serializable a, Serializable b) + => Condition s a + -> StatelessCallHandler s a b + -> Dispatcher s +handleCallFromIf_ cond handler = + DispatchIf { + dispatch = \_ (CallMessage p c) -> handler c p >>= mkReply c + , dispatchIf = checkCall cond + } + +-- | As 'handleCall' but passes the 'CallRef' to the handler function. +-- This can be useful if you wish to /reply later/ to the caller by, e.g., +-- spawning a process to do some work and have it @replyTo caller response@ +-- out of band. In this case the callback can pass the 'CallRef' to the +-- worker (or stash it away itself) and return 'noReply'. +-- +handleCallFrom :: forall s a b . (Serializable a, Serializable b) + => DeferredCallHandler s a b + -> Dispatcher s +handleCallFrom = handleCallFromIf $ state (const True) + +-- | As 'handleCallFrom' but only runs the handler if the supplied 'Condition' +-- evaluates to @True@. +-- +handleCallFromIf :: forall s a b . (Serializable a, Serializable b) + => Condition s a -- ^ predicate that must be satisfied for the handler to run + -> DeferredCallHandler s a b + -- ^ a reply yielding function over the process state, sender and input message + -> Dispatcher s +handleCallFromIf cond handler + = DispatchIf { + dispatch = \s (CallMessage p c) -> handler c s p >>= mkReply c + , dispatchIf = checkCall cond + } + +-- | Creates a handler for a /typed channel/ RPC style interaction. The +-- handler takes a @SendPort b@ to reply to, the initial input and evaluates +-- to a 'ProcessAction'. It is the handler code's responsibility to send the +-- reply to the @SendPort@. +-- +handleRpcChan :: forall s a b . (Serializable a, Serializable b) + => ChannelHandler s a b + -> Dispatcher s +handleRpcChan = handleRpcChanIf $ input (const True) + +-- | As 'handleRpcChan', but only evaluates the handler if the supplied +-- condition is met. +-- +handleRpcChanIf :: forall s a b . (Serializable a, Serializable b) + => Condition s a + -> ChannelHandler s a b + -> Dispatcher s +handleRpcChanIf cond handler + = DispatchIf { + dispatch = \s (ChanMessage p c) -> handler c s p + , dispatchIf = checkRpc cond + } + +-- | A variant of 'handleRpcChan' that ignores the state argument. +-- +handleRpcChan_ :: forall s a b . (Serializable a, Serializable b) + => StatelessChannelHandler s a b + -- (SendPort b -> a -> (s -> Action s)) + -> Dispatcher s +handleRpcChan_ = handleRpcChanIf_ $ input (const True) + +-- | A variant of 'handleRpcChanIf' that ignores the state argument. +-- +handleRpcChanIf_ :: forall s a b . (Serializable a, Serializable b) + => Condition s a + -> StatelessChannelHandler s a b + -> Dispatcher s +handleRpcChanIf_ c h + = DispatchIf { dispatch = \s ((ChanMessage m p) :: Message a b) -> h p m s + , dispatchIf = checkRpc c + } + +-- | Constructs a 'cast' handler from an ordinary function in the 'Process' +-- monad. +-- > handleCast = handleCastIf (const True) +-- +handleCast :: (Serializable a) + => CastHandler s a + -> Dispatcher s +handleCast = handleCastIf $ input (const True) + +-- | Constructs a 'cast' handler from an ordinary function in the 'Process' +-- monad. Given a function @f :: (s -> a -> Process (ProcessAction s))@, +-- the expression @handleCall f@ will yield a 'Dispatcher' for inclusion +-- in a 'Behaviour' specification for the /GenProcess/. +-- +handleCastIf :: forall s a . (Serializable a) + => Condition s a -- ^ predicate that must be satisfied for the handler to run + -> CastHandler s a + -- ^ an action yielding function over the process state and input message + -> Dispatcher s +handleCastIf cond h + = DispatchIf { + dispatch = \s ((CastMessage p) :: Message a ()) -> h s p + , dispatchIf = checkCast cond + } + +-- | Creates a generic input handler for @STM@ actions, from an ordinary +-- function in the 'Process' monad. The @STM a@ action tells the server how +-- to read inputs, which when presented are passed to the handler in the same +-- manner as @handleInfo@ messages would be. +-- +-- Note that messages sent to the server's mailbox will never match this +-- handler, only data arriving via the @STM a@ action will. +-- +-- Notably, this kind of handler can be used to pass non-serialisable data to +-- a server process. In such situations, the programmer is responsible for +-- managing the underlying @STM@ infrastructure, and the server simply composes +-- the @STM a@ action with the other reads on its mailbox, using the underlying +-- @matchSTM@ API from distributed-process. +-- +-- NB: this function cannot be used with a prioristised process definition. +-- +handleExternal :: forall s a . (Serializable a) + => STM a + -> ActionHandler s a + -> ExternDispatcher s +handleExternal a h = + let matchMsg' = matchSTM a (\(m :: r) -> return $ unsafeWrapMessage m) + matchAny' f = matchSTM a (\(m :: r) -> return $ f (unsafeWrapMessage m)) in + DispatchSTM + { stmAction = a + , dispatchStm = h + , matchStm = matchMsg' + , matchAnyStm = matchAny' + } + +-- | Version of @handleExternal@ that ignores state. +handleExternal_ :: forall s a . (Serializable a) + => STM a + -> StatelessHandler s a + -> ExternDispatcher s +handleExternal_ a h = handleExternal a (flip h) + +-- | Handle @call@ style API interactions using arbitrary /STM/ actions. +-- +-- The usual @CallHandler@ is preceded by an stm action that, when evaluated, +-- yields a value, and a second expression that is used to send a reply back +-- to the /caller/. The corrolary client API is /callSTM/. +-- +handleCallExternal :: forall s r w . (Serializable r) + => STM r + -> (w -> STM ()) + -> CallHandler s r w + -> ExternDispatcher s +handleCallExternal reader writer handler = + let matchMsg' = matchSTM reader (\(m :: r) -> return $ unsafeWrapMessage m) + matchAny' f = matchSTM reader (\(m :: r) -> return $ f $ unsafeWrapMessage m) in + DispatchSTM + { stmAction = reader + , dispatchStm = doStmReply handler + , matchStm = matchMsg' + , matchAnyStm = matchAny' + } + where + doStmReply d s m = d s m >>= doXfmReply writer + + doXfmReply _ (NoReply a) = return a + doXfmReply _ (ProcessReject _ a) = return a + doXfmReply w (ProcessReply r' a) = liftIO (atomically $ w r') >> return a + +-- | Constructs a /control channel/ handler from a function in the +-- 'Process' monad. The handler expression returns no reply, and the +-- /control message/ is treated in the same fashion as a 'cast'. +-- +-- > handleControlChan = handleControlChanIf $ input (const True) +-- +handleControlChan :: forall s a . (Serializable a) + => ControlChannel a -- ^ the receiving end of the control channel + -> ActionHandler s a + -- ^ an action yielding function over the process state and input message + -> ExternDispatcher s +handleControlChan chan h + = DispatchCC { channel = snd $ unControl chan + , dispatchChan = \s ((CastMessage p) :: Message a ()) -> h s p + } + +-- | Version of 'handleControlChan' that ignores the server state. +-- +handleControlChan_ :: forall s a. (Serializable a) + => ControlChannel a + -> StatelessHandler s a + -> ExternDispatcher s +handleControlChan_ chan h + = DispatchCC { channel = snd $ unControl chan + , dispatchChan = \s ((CastMessage p) :: Message a ()) -> h p s + } + +-- | Version of 'handleCast' that ignores the server state. +-- +handleCast_ :: (Serializable a) + => StatelessHandler s a + -> Dispatcher s +handleCast_ = handleCastIf_ $ input (const True) + +-- | Version of 'handleCastIf' that ignores the server state. +-- +handleCastIf_ :: forall s a . (Serializable a) + => Condition s a -- ^ predicate that must be satisfied for the handler to run + -> StatelessHandler s a + -- ^ a function from the input message to a /stateless action/, cf 'continue_' + -> Dispatcher s +handleCastIf_ cond h + = DispatchIf { dispatch = \s ((CastMessage p) :: Message a ()) -> h p $ s + , dispatchIf = checkCast cond + } + +-- | Constructs an /action/ handler. Like 'handleDispatch' this can handle both +-- 'cast' and 'call' messages, but you won't know which you're dealing with. +-- This can be useful where certain inputs require a definite action, such as +-- stopping the server, without concern for the state (e.g., when stopping we +-- need only decide to stop, as the terminate handler can deal with state +-- cleanup etc). For example: +-- +-- @action (\MyCriticalSignal -> stop_ ExitNormal)@ +-- +action :: forall s a . (Serializable a) + => StatelessHandler s a + -- ^ a function from the input message to a /stateless action/, cf 'continue_' + -> Dispatcher s +action h = handleDispatch perform + where perform :: ActionHandler s a + perform s a = let f = h a in f s + +-- | Constructs a handler for both /call/ and /cast/ messages. +-- @handleDispatch = handleDispatchIf (const True)@ +-- +handleDispatch :: forall s a . (Serializable a) + => ActionHandler s a + -> Dispatcher s +handleDispatch = handleDispatchIf $ input (const True) + +-- | Constructs a handler for both /call/ and /cast/ messages. Messages are only +-- dispatched to the handler if the supplied condition evaluates to @True@. +-- Handlers defined in this way have no access to the call context (if one +-- exists) and cannot therefore reply to calls. +-- +handleDispatchIf :: forall s a . (Serializable a) + => Condition s a + -> ActionHandler s a + -> Dispatcher s +handleDispatchIf cond handler = DispatchIf { + dispatch = doHandle handler + , dispatchIf = check cond + } + where doHandle :: (Serializable a) + => ActionHandler s a + -> s + -> Message a () + -> Process (ProcessAction s) + doHandle h s msg = + case msg of + (CallMessage p _) -> h s p + (CastMessage p) -> h s p + (ChanMessage p _) -> h s p + +-- | Creates a generic input handler (i.e., for received messages that are /not/ +-- sent using the 'cast' or 'call' APIs) from an ordinary function in the +-- 'Process' monad. +handleInfo :: forall s a. (Serializable a) + => ActionHandler s a + -> DeferredDispatcher s +handleInfo h = DeferredDispatcher { dispatchInfo = doHandleInfo h } + where + doHandleInfo :: forall s2 a2. (Serializable a2) + => ActionHandler s2 a2 + -> s2 + -> P.Message + -> Process (Maybe (ProcessAction s2)) + doHandleInfo h' s msg = handleMessage msg (h' s) + +-- | Handle completely /raw/ input messages. +-- +handleRaw :: forall s. ActionHandler s P.Message + -> DeferredDispatcher s +handleRaw h = DeferredDispatcher { dispatchInfo = doHandle h } + where + doHandle h' s msg = fmap Just (h' s msg) + +-- | Creates an /exit handler/ scoped to the execution of any and all the +-- registered call, cast and info handlers for the process. +handleExit :: forall s a. (Serializable a) + => (ProcessId -> ActionHandler s a) + -> ExitSignalDispatcher s +handleExit h = ExitSignalDispatcher { dispatchExit = doHandleExit h } + where + doHandleExit :: (ProcessId -> ActionHandler s a) + -> s + -> ProcessId + -> P.Message + -> Process (Maybe (ProcessAction s)) + doHandleExit h' s p msg = handleMessage msg (h' p s) + +-- | Conditional version of @handleExit@ +handleExitIf :: forall s a . (Serializable a) + => (s -> a -> Bool) + -> (ProcessId -> ActionHandler s a) + -> ExitSignalDispatcher s +handleExitIf c h = ExitSignalDispatcher { dispatchExit = doHandleExit c h } + where + doHandleExit :: (s -> a -> Bool) + -> (ProcessId -> ActionHandler s a) + -> s + -> ProcessId + -> P.Message + -> Process (Maybe (ProcessAction s)) + doHandleExit c' h' s p msg = handleMessageIf msg (c' s) (h' p s) + +-- handling 'reply-to' in the main process loop is awkward at best, +-- so we handle it here instead and return the 'action' to the loop +mkReply :: (Serializable b) + => CallRef b + -> ProcessReply b s + -> Process (ProcessAction s) +mkReply cRef act + | (NoReply a) <- act = return a + | (CallRef (_, tg')) <- cRef + , (ProcessReply r' a) <- act = sendTo cRef (CallResponse r' tg') >> return a + | (CallRef (_, ct')) <- cRef + , (ProcessReject r' a) <- act = sendTo cRef (CallRejected r' ct') >> return a + | otherwise = die $ ExitOther "mkReply.InvalidState" + +-- these functions are the inverse of 'condition', 'state' and 'input' + +check :: forall s m a . (Serializable m) + => Condition s m + -> s + -> Message m a + -> Bool +check (Condition c) st msg = c st $ decode msg +check (State c) st _ = c st +check (Input c) _ msg = c $ decode msg + +checkRpc :: forall s m a . (Serializable m) + => Condition s m + -> s + -> Message m a + -> Bool +checkRpc cond st msg@(ChanMessage _ _) = check cond st msg +checkRpc _ _ _ = False + +checkCall :: forall s m a . (Serializable m) + => Condition s m + -> s + -> Message m a + -> Bool +checkCall cond st msg@(CallMessage _ _) = check cond st msg +checkCall _ _ _ = False + +checkCast :: forall s m . (Serializable m) + => Condition s m + -> s + -> Message m () + -> Bool +checkCast cond st msg@(CastMessage _) = check cond st msg +checkCast _ _ _ = False + +decode :: Message a b -> a +decode (CallMessage a _) = a +decode (CastMessage a) = a +decode (ChanMessage a _) = a diff --git a/packages/distributed-process-client-server/src/Control/Distributed/Process/ManagedProcess/Server/Gen.hs b/packages/distributed-process-client-server/src/Control/Distributed/Process/ManagedProcess/Server/Gen.hs new file mode 100644 index 00000000..90baf591 --- /dev/null +++ b/packages/distributed-process-client-server/src/Control/Distributed/Process/ManagedProcess/Server/Gen.hs @@ -0,0 +1,181 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE AllowAmbiguousTypes #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Distributed.Process.ManagedProcess.Server.Priority +-- Copyright : (c) Tim Watson 2012 - 2017 +-- License : BSD3 (see the file LICENSE) +-- +-- Maintainer : Tim Watson +-- Stability : experimental +-- Portability : non-portable (requires concurrency) +-- +-- The Server Portion of the /Managed Process/ API, as presented by the +-- 'GenProcess' monad. These functions are generally intended for internal +-- use, but the API is relatively stable and therefore they have been re-exported +-- here for general use. Note that if you modify a process' internal state +-- (especially that of the internal priority queue) then you are responsible for +-- any alteratoin that makes to the semantics of your processes behaviour. +-- +-- See "Control.Distributed.Process.ManagedProcess.Internal.GenProcess" +----------------------------------------------------------------------------- +module Control.Distributed.Process.ManagedProcess.Server.Gen + ( -- * Server actions + reply + , replyWith + , noReply + , continue + , timeoutAfter + , hibernate + , stop + , reject + , rejectWith + , become + , haltNoReply + , lift + , Gen.recvLoop + , Gen.precvLoop + , Gen.currentTimeout + , Gen.systemTimeout + , Gen.drainTimeout + , Gen.processState + , Gen.processDefinition + , Gen.processFilters + , Gen.processUnhandledMsgPolicy + , Gen.processQueue + , Gen.gets + , Gen.getAndModifyState + , Gen.modifyState + , Gen.setUserTimeout + , Gen.setProcessState + , GenProcess + , Gen.peek + , Gen.push + , Gen.enqueue + , Gen.dequeue + , Gen.addUserTimer + , Gen.removeUserTimer + , Gen.eval + , Gen.act + , Gen.runAfter + , Gen.evalAfter + ) where + +import Control.Distributed.Process.Extras + ( ExitReason + ) +import Control.Distributed.Process.Extras.Time + ( TimeInterval + , Delay + ) +import Control.Distributed.Process.ManagedProcess.Internal.Types + ( lift + , ProcessAction(..) + , GenProcess + , ProcessReply(..) + , ProcessDefinition + ) +import qualified Control.Distributed.Process.ManagedProcess.Internal.GenProcess as Gen + ( recvLoop + , precvLoop + , currentTimeout + , systemTimeout + , drainTimeout + , processState + , processDefinition + , processFilters + , processUnhandledMsgPolicy + , processQueue + , gets + , getAndModifyState + , modifyState + , setUserTimeout + , setProcessState + , GenProcess + , peek + , push + , enqueue + , dequeue + , addUserTimer + , removeUserTimer + , eval + , act + , runAfter + , evalAfter + ) +import Control.Distributed.Process.ManagedProcess.Internal.GenProcess + ( processState + ) +import qualified Control.Distributed.Process.ManagedProcess.Server as Server + ( replyWith + , continue + ) +import Control.Distributed.Process.Serializable (Serializable) + +-- | Reject the message we're currently handling. +reject :: forall r s . String -> GenProcess s (ProcessReply r s) +reject rs = processState >>= \st -> lift $ Server.continue st >>= return . ProcessReject rs + +-- | Reject the message we're currently handling, giving an explicit reason. +rejectWith :: forall r m s . (Show r) => r -> GenProcess s (ProcessReply m s) +rejectWith rs = reject (show rs) + +-- | Instructs the process to send a reply and continue running. +reply :: forall r s . (Serializable r) => r -> GenProcess s (ProcessReply r s) +reply r = processState >>= \s -> lift $ Server.continue s >>= Server.replyWith r + +-- | Instructs the process to send a reply /and/ evaluate the 'ProcessAction'. +replyWith :: forall r s . (Serializable r) + => r + -> ProcessAction s + -> GenProcess s (ProcessReply r s) +replyWith r s = return $ ProcessReply r s + +-- | Instructs the process to skip sending a reply /and/ evaluate a 'ProcessAction' +noReply :: (Serializable r) => ProcessAction s -> GenProcess s (ProcessReply r s) +noReply = return . NoReply + +-- | Halt process execution during a call handler, without paying any attention +-- to the expected return type. +haltNoReply :: forall s r . Serializable r => ExitReason -> GenProcess s (ProcessReply r s) +haltNoReply r = stop r >>= noReply + +-- | Instructs the process to continue running and receiving messages. +continue :: GenProcess s (ProcessAction s) +continue = processState >>= return . ProcessContinue + +-- | Instructs the process loop to wait for incoming messages until 'Delay' +-- is exceeded. If no messages are handled during this period, the /timeout/ +-- handler will be called. Note that this alters the process timeout permanently +-- such that the given @Delay@ will remain in use until changed. +-- +-- Note that @timeoutAfter NoDelay@ will cause the timeout handler to execute +-- immediately if no messages are present in the process' mailbox. +-- +timeoutAfter :: Delay -> GenProcess s (ProcessAction s) +timeoutAfter d = processState >>= \s -> return $ ProcessTimeout d s + +-- | Instructs the process to /hibernate/ for the given 'TimeInterval'. Note +-- that no messages will be removed from the mailbox until after hibernation has +-- ceased. This is equivalent to calling @threadDelay@. +-- +hibernate :: TimeInterval -> GenProcess s (ProcessAction s) +hibernate d = processState >>= \s -> return $ ProcessHibernate d s + +-- | The server loop will execute against the supplied 'ProcessDefinition', allowing +-- the process to change its behaviour (in terms of message handlers, exit handling, +-- termination, unhandled message policy, etc) +become :: forall s . ProcessDefinition s -> GenProcess s (ProcessAction s) +become def = processState >>= \st -> return $ ProcessBecome def st + +-- | Instructs the process to terminate, giving the supplied reason. If a valid +-- 'shutdownHandler' is installed, it will be called with the 'ExitReason' +-- returned from this call, along with the process state. +stop :: ExitReason -> GenProcess s (ProcessAction s) +stop r = return $ ProcessStop r diff --git a/packages/distributed-process-client-server/src/Control/Distributed/Process/ManagedProcess/Server/Priority.hs b/packages/distributed-process-client-server/src/Control/Distributed/Process/ManagedProcess/Server/Priority.hs new file mode 100644 index 00000000..b5045fc7 --- /dev/null +++ b/packages/distributed-process-client-server/src/Control/Distributed/Process/ManagedProcess/Server/Priority.hs @@ -0,0 +1,377 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE AllowAmbiguousTypes #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Distributed.Process.ManagedProcess.Server.Priority +-- Copyright : (c) Tim Watson 2012 - 2017 +-- License : BSD3 (see the file LICENSE) +-- +-- Maintainer : Tim Watson +-- Stability : experimental +-- Portability : non-portable (requires concurrency) +-- +-- The Prioritised Server portion of the /Managed Process/ API. +----------------------------------------------------------------------------- +module Control.Distributed.Process.ManagedProcess.Server.Priority + ( -- * Prioritising API Handlers + prioritiseCall + , prioritiseCall_ + , prioritiseCast + , prioritiseCast_ + , prioritiseInfo + , prioritiseInfo_ + , setPriority + -- * Creating Filters + , check + , raw + , raw_ + , api + , api_ + , info + , info_ + , refuse + , reject + , rejectApi + , store + , storeM + , crash + , ensure + , ensureM + , Filter() + , DispatchFilter() + , safe + , apiSafe + , safely + , Message() + , evalAfter + , currentTimeout + , processState + , processDefinition + , processFilters + , processUnhandledMsgPolicy + , setUserTimeout + , setProcessState + , GenProcess + , peek + , push + , addUserTimer + , act + , runAfter + ) where + +import Control.Distributed.Process hiding (call, Message) +import qualified Control.Distributed.Process as P (Message) +import Control.Distributed.Process.Extras + ( ExitReason(..) + ) +import Control.Distributed.Process.ManagedProcess.Internal.GenProcess + ( addUserTimer + , currentTimeout + , processState + , processDefinition + , processFilters + , processUnhandledMsgPolicy + , setUserTimeout + , setProcessState + , GenProcess + , peek + , push + , evalAfter + , act + , runAfter + ) +import Control.Distributed.Process.ManagedProcess.Internal.Types +import Control.Distributed.Process.Serializable +import Prelude hiding (init) + +-- | Sent to a caller in cases where the server is rejecting an API input and +-- a @Recipient@ is available (i.e. a /call/ message handling filter). +data RejectedByServer = RejectedByServer deriving (Show) + +-- | Represents a pair of expressions that can be used to define a @DispatchFilter@. +data FilterHandler s = + forall m . (Serializable m) => + HandlePure + { + pureCheck :: s -> m -> Process Bool + , handler :: s -> m -> Process (Filter s) + } -- ^ A pure handler, usable where the target handler is based on @handleInfo@ + | forall m b . (Serializable m, Serializable b) => + HandleApi + { + apiCheck :: s -> m -> Process Bool + , apiHandler :: s -> Message m b -> Process (Filter s) + } -- ^ An API handler, usable where the target handler is based on @handle{Call, Cast, RpcChan}@ + | HandleRaw + { + rawCheck :: s -> P.Message -> Process Bool + , rawHandler :: s -> P.Message -> Process (Maybe (Filter s)) + } -- ^ A raw handler, usable where the target handler is based on @handleRaw@ + | HandleState { stateHandler :: s -> Process (Maybe (Filter s)) } + | HandleSafe + { + safeCheck :: s -> P.Message -> Process Bool + } -- ^ A safe wrapper + +{- +check :: forall c s m . (Check c s m) + => c -> (s -> Process (Filter s)) -> s -> m -> Process (Filter s) +-} + +-- | Create a filter from a @FilterHandler@. +check :: forall s . FilterHandler s -> DispatchFilter s +check h + | HandlePure{..} <- h = FilterAny $ \s m -> pureCheck s m >>= procUnless s m handler + | HandleRaw{..} <- h = FilterRaw $ \s m -> do + c <- rawCheck s m + if c then return $ Just $ FilterOk s + else rawHandler s m + | HandleState{..} <- h = FilterState stateHandler + | HandleApi{..} <- h = FilterApi $ \s m@(CallMessage m' _) -> do + c <- apiCheck s m' + if c then return $ FilterOk s + else apiHandler s m + | HandleSafe{..} <- h = FilterRaw $ \s m -> do + c <- safeCheck s m + let ctr = if c then FilterSafe else FilterOk + return $ Just $ ctr s + + where + procUnless s _ _ True = return $ FilterOk s + procUnless s m h' False = h' s m + +-- | A raw filter (targetting raw messages). +raw :: forall s . + (s -> P.Message -> Process Bool) + -> (s -> P.Message -> Process (Maybe (Filter s))) + -> FilterHandler s +raw = HandleRaw + +-- | A raw filter that ignores the server state in its condition expression. +raw_ :: forall s . + (P.Message -> Process Bool) + -> (s -> P.Message -> Process (Maybe (Filter s))) + -> FilterHandler s +raw_ c h = raw (const $ c) h + +-- | An API filter (targetting /call/, /cast/, and /chan/ messages). +api :: forall s m b . (Serializable m, Serializable b) + => (s -> m -> Process Bool) + -> (s -> Message m b -> Process (Filter s)) + -> FilterHandler s +api = HandleApi + +-- | An API filter that ignores the server state in its condition expression. +api_ :: forall m b s . (Serializable m, Serializable b) + => (m -> Process Bool) + -> (s -> Message m b -> Process (Filter s)) + -> FilterHandler s +api_ c h = api (const $ c) h + +-- | An info filter (targetting info messages of a specific type) +info :: forall s m . (Serializable m) + => (s -> m -> Process Bool) + -> (s -> m -> Process (Filter s)) + -> FilterHandler s +info = HandlePure + +-- | An info filter that ignores the server state in its condition expression. +info_ :: forall s m . (Serializable m) + => (m -> Process Bool) + -> (s -> m -> Process (Filter s)) + -> FilterHandler s +info_ c h = info (const $ c) h + +-- | As 'safe', but as applied to api messages (i.e. those originating from +-- call as cast client interactions). +apiSafe :: forall s m b . (Serializable m, Serializable b) + => (s -> m -> Maybe b -> Bool) + -> DispatchFilter s +apiSafe c = check $ HandleSafe (go c) + where + go c' s (i :: P.Message) = do + m <- unwrapMessage i :: Process (Maybe (Message m b)) + case m of + Just (CallMessage m' _) -> return $ c' s m' Nothing + Just (CastMessage m') -> return $ c' s m' Nothing + Just (ChanMessage m' _) -> return $ c' s m' Nothing + Nothing -> return False + +-- | Given a check expression, if it evaluates to @True@ for some input, +-- then do not dequeue the message until after any matching handlers have +-- successfully run, or the the unhandled message policy is chosen if none match. +-- Thus, if an exit signal (async exception) terminates execution of a handler, and we +-- have an installed exit handler which allows the process to continue running, +-- we will retry the input in question since it has not been fully dequeued prior +-- to the exit signal arriving. +safe :: forall s m . (Serializable m) + => (s -> m -> Bool) + -> DispatchFilter s +safe c = check $ HandleSafe (go c) + where + go c' s (i :: P.Message) = do + m <- unwrapMessage i :: Process (Maybe m) + case m of + Just m' -> return $ c' s m' + Nothing -> return False + +-- | As 'safe', but matches on a raw message. +safely :: forall s . (s -> P.Message -> Bool) -> DispatchFilter s +safely c = check $ HandleSafe $ \s m -> return (c s m) + +-- | Create a filter expression that will reject all messages of a specific type. +reject :: forall s m r . (Show r) + => r -> s -> m -> Process (Filter s) +reject r = \s _ -> do return $ FilterReject (show r) s + +-- | Create a filter expression that will crash (i.e. stop) the server. +crash :: forall s . s -> ExitReason -> Process (Filter s) +crash s r = return $ FilterStop s r + +-- | A version of @reject@ that deals with API messages (i.e. /call/, /cast/, etc) +-- and in the case of a /call/ interaction, will reject the messages and reply to +-- the sender accordingly (with @CallRejected@). +rejectApi :: forall s m b r . (Show r, Serializable m, Serializable b) + => r -> s -> Message m b -> Process (Filter s) +rejectApi r = \s m -> do let r' = show r + rejectToCaller m r' + return $ FilterSkip s + +-- | Modify the server state every time a message is recieved. +store :: (s -> s) -> DispatchFilter s +store f = FilterState $ return . Just . FilterOk . f + +-- | Motify the server state when messages of a certain type arrive... +storeM :: forall s m . (Serializable m) + => (s -> m -> Process s) + -> DispatchFilter s +storeM proc = check $ HandlePure (\_ _ -> return True) + (\s m -> proc s m >>= return . FilterOk) + +-- | Refuse messages for which the given expression evaluates to @True@. +refuse :: forall s m . (Serializable m) + => (m -> Bool) + -> DispatchFilter s +refuse c = check $ info (const $ \m -> return $ c m) (reject RejectedByServer) + +{- +apiCheck :: forall s m r . (Serializable m, Serializable r) + => (s -> Message m r -> Bool) + -> (s -> Message m r -> Process (Filter s)) + -> DispatchFilter s +apiCheck c h = checkM (\s m -> return $ c s m) h +-} + +-- | Ensure that the server state is consistent with the given expression each +-- time a message arrives/is processed. If the expression evaluates to @True@ +-- then the filter will evaluate to "FilterOk", otherwise "FilterStop" (which +-- will cause the server loop to stop with @ExitOther filterFail@). +ensure :: forall s . (s -> Bool) -> DispatchFilter s +ensure c = + check $ HandleState { stateHandler = (\s -> if c s + then return $ Just $ FilterOk s + else return $ Just $ FilterStop s filterFail) + } +-- | As @ensure@ but runs in the @Process@ monad, and matches only inputs of type @m@. +ensureM :: forall s m . (Serializable m) => (s -> m -> Process Bool) -> DispatchFilter s +ensureM c = + check $ HandlePure { pureCheck = c + , handler = (\s _ -> return $ FilterStop s filterFail) :: s -> m -> Process (Filter s) + } + +-- TODO: add the type rep for a more descriptive failure message + +filterFail :: ExitReason +filterFail = ExitOther "Control.Distributed.Process.ManagedProcess.Priority:FilterFailed" + +-- | Sets an explicit priority from 1..100. Values > 100 are rounded to 100, +-- and values < 1 are set to 0. +setPriority :: Int -> Priority m +setPriority n + | n < 1 = Priority 0 + | n > 100 = Priority 100 + | otherwise = Priority n + +-- | Prioritise a call handler, ignoring the server's state +prioritiseCall_ :: forall s a b . (Serializable a, Serializable b) + => (a -> Priority b) + -> DispatchPriority s +prioritiseCall_ h = prioritiseCall (const h) + +-- | Prioritise a call handler +prioritiseCall :: forall s a b . (Serializable a, Serializable b) + => (s -> a -> Priority b) + -> DispatchPriority s +prioritiseCall h = PrioritiseCall (unCall . h) + where + unCall :: (a -> Priority b) -> P.Message -> Process (Maybe (Int, P.Message)) + unCall h' m = fmap (matchPrioritise m h') (unwrapMessage m) + + matchPrioritise :: P.Message + -> (a -> Priority b) + -> Maybe (Message a b) + -> Maybe (Int, P.Message) + matchPrioritise msg p msgIn + | (Just a@(CallMessage m _)) <- msgIn + , True <- isEncoded msg = Just (getPrio $ p m, wrapMessage a) + | (Just (CallMessage m _)) <- msgIn + , False <- isEncoded msg = Just (getPrio $ p m, msg) + | otherwise = Nothing + +-- | Prioritise a cast handler, ignoring the server's state +prioritiseCast_ :: forall s a . (Serializable a) + => (a -> Priority ()) + -> DispatchPriority s +prioritiseCast_ h = prioritiseCast (const h) + +-- | Prioritise a cast handler +prioritiseCast :: forall s a . (Serializable a) + => (s -> a -> Priority ()) + -> DispatchPriority s +prioritiseCast h = PrioritiseCast (unCast . h) + where + unCast :: (a -> Priority ()) -> P.Message -> Process (Maybe (Int, P.Message)) + unCast h' m = fmap (matchPrioritise m h') (unwrapMessage m) + + matchPrioritise :: P.Message + -> (a -> Priority ()) + -> Maybe (Message a ()) + -> Maybe (Int, P.Message) + matchPrioritise msg p msgIn + | (Just a@(CastMessage m)) <- msgIn + , True <- isEncoded msg = Just (getPrio $ p m, wrapMessage a) + | (Just (CastMessage m)) <- msgIn + , False <- isEncoded msg = Just (getPrio $ p m, msg) + | otherwise = Nothing + +-- | Prioritise an info handler, ignoring the server's state +prioritiseInfo_ :: forall s a . (Serializable a) + => (a -> Priority ()) + -> DispatchPriority s +prioritiseInfo_ h = prioritiseInfo (const h) + +-- | Prioritise an info handler +prioritiseInfo :: forall s a . (Serializable a) + => (s -> a -> Priority ()) + -> DispatchPriority s +prioritiseInfo h = PrioritiseInfo (unMsg . h) + where + unMsg :: (a -> Priority ()) -> P.Message -> Process (Maybe (Int, P.Message)) + unMsg h' m = fmap (matchPrioritise m h') (unwrapMessage m) + + matchPrioritise :: P.Message + -> (a -> Priority ()) + -> Maybe a + -> Maybe (Int, P.Message) + matchPrioritise msg p msgIn + | (Just m') <- msgIn + , True <- isEncoded msg = Just (getPrio $ p m', wrapMessage m') + | (Just m') <- msgIn + , False <- isEncoded msg = Just (getPrio $ p m', msg) + | otherwise = Nothing diff --git a/packages/distributed-process-client-server/src/Control/Distributed/Process/ManagedProcess/Server/Restricted.hs b/packages/distributed-process-client-server/src/Control/Distributed/Process/ManagedProcess/Server/Restricted.hs new file mode 100644 index 00000000..9ad814a7 --- /dev/null +++ b/packages/distributed-process-client-server/src/Control/Distributed/Process/ManagedProcess/Server/Restricted.hs @@ -0,0 +1,270 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Distributed.Process.ManagedProcess.Server.Restricted +-- Copyright : (c) Tim Watson 2012 - 2017 +-- License : BSD3 (see the file LICENSE) +-- +-- Maintainer : Tim Watson +-- Stability : experimental +-- Portability : non-portable (requires concurrency) +-- +-- A /safe/ variant of the Server Portion of the /Managed Process/ API. Most +-- of these operations have the same names as similar operations in the impure +-- @Server@ module (re-exported by the primary API in @ManagedProcess@). To +-- remove the ambiguity, some combination of either qualification and/or the +-- @hiding@ clause will be required. +-- +-- [Restricted Server Callbacks] +-- +-- The idea behind this module is to provide /safe/ callbacks, i.e., server +-- code that is free from side effects. This safety is enforced by the type +-- system via the @RestrictedProcess@ monad. A StateT interface is provided +-- for code running in the @RestrictedProcess@ monad, so that server side +-- state can be managed safely without resorting to IO (or code running in +-- the @Process@ monad). +-- +----------------------------------------------------------------------------- + +module Control.Distributed.Process.ManagedProcess.Server.Restricted + ( -- * Exported Types + RestrictedProcess + , Result(..) + , RestrictedAction(..) + -- * Creating call/cast protocol handlers + , handleCall + , handleCallIf + , handleCast + , handleCastIf + , handleInfo + , handleExit + , handleTimeout + -- * Handling Process State + , putState + , getState + , modifyState + -- * Handling responses/transitions + , reply + , noReply + , haltNoReply + , continue + , timeoutAfter + , hibernate + , stop + -- * Utilities + , say + ) where + +import Control.Distributed.Process hiding (call, say) +import qualified Control.Distributed.Process as P (say) +import Control.Distributed.Process.Extras + (ExitReason(..)) +import Control.Distributed.Process.ManagedProcess.Internal.Types hiding (lift) +import qualified Control.Distributed.Process.ManagedProcess.Server as Server +import Control.Distributed.Process.Extras.Time +import Control.Distributed.Process.Serializable +import Prelude hiding (init) + +import Control.Monad.IO.Class (MonadIO) +import qualified Control.Monad.State as ST + ( MonadState + , StateT + , get + , lift + , modify + , put + , runStateT + ) + +import Data.Typeable + +-- | Restricted (i.e., pure, free from side effects) execution +-- environment for call/cast/info handlers to execute in. +-- +newtype RestrictedProcess s a = RestrictedProcess { + unRestricted :: ST.StateT s Process a + } + deriving (Functor, Monad, ST.MonadState s, MonadIO, Typeable, Applicative) + +-- | The result of a 'call' handler's execution. +data Result a = + Reply a -- ^ reply with the given term + | Timeout Delay a -- ^ reply with the given term and enter timeout + | Hibernate TimeInterval a -- ^ reply with the given term and hibernate + | Stop ExitReason -- ^ stop the process with the given reason + deriving (Typeable) + +-- | The result of a safe 'cast' handler's execution. +data RestrictedAction = + RestrictedContinue -- ^ continue executing + | RestrictedTimeout Delay -- ^ timeout if no messages are received + | RestrictedHibernate TimeInterval -- ^ hibernate (i.e., sleep) + | RestrictedStop ExitReason -- ^ stop/terminate the server process + +-------------------------------------------------------------------------------- +-- Handling state in RestrictedProcess execution environments -- +-------------------------------------------------------------------------------- + +-- | Log a trace message using the underlying Process's @say@ +say :: String -> RestrictedProcess s () +say = lift . P.say + +-- | Get the current process state +getState :: RestrictedProcess s s +getState = ST.get + +-- | Put a new process state state +putState :: s -> RestrictedProcess s () +putState = ST.put + +-- | Apply the given expression to the current process state +modifyState :: (s -> s) -> RestrictedProcess s () +modifyState = ST.modify + +-------------------------------------------------------------------------------- +-- Generating replies and state transitions inside RestrictedProcess -- +-------------------------------------------------------------------------------- + +-- | Instructs the process to send a reply and continue running. +reply :: forall s r . (Serializable r) => r -> RestrictedProcess s (Result r) +reply = return . Reply + +-- | Continue without giving a reply to the caller - equivalent to 'continue', +-- but usable in a callback passed to the 'handleCall' family of functions. +noReply :: forall s r . (Serializable r) + => Result r + -> RestrictedProcess s (Result r) +noReply = return + +-- | Halt process execution during a call handler, without paying any attention +-- to the expected return type. +haltNoReply :: forall s r . (Serializable r) + => ExitReason + -> RestrictedProcess s (Result r) +haltNoReply r = noReply (Stop r) + +-- | Instructs the process to continue running and receiving messages. +continue :: forall s . RestrictedProcess s RestrictedAction +continue = return RestrictedContinue + +-- | Instructs the process loop to wait for incoming messages until 'Delay' +-- is exceeded. If no messages are handled during this period, the /timeout/ +-- handler will be called. Note that this alters the process timeout permanently +-- such that the given @Delay@ will remain in use until changed. +timeoutAfter :: forall s. Delay -> RestrictedProcess s RestrictedAction +timeoutAfter d = return $ RestrictedTimeout d + +-- | Instructs the process to /hibernate/ for the given 'TimeInterval'. Note +-- that no messages will be removed from the mailbox until after hibernation has +-- ceased. This is equivalent to evaluating @liftIO . threadDelay@. +-- +hibernate :: forall s. TimeInterval -> RestrictedProcess s RestrictedAction +hibernate d = return $ RestrictedHibernate d + +-- | Instructs the process to terminate, giving the supplied reason. If a valid +-- 'shutdownHandler' is installed, it will be called with the 'ExitReason' +-- returned from this call, along with the process state. +stop :: forall s. ExitReason -> RestrictedProcess s RestrictedAction +stop r = return $ RestrictedStop r + +-------------------------------------------------------------------------------- +-- Wrapping handler expressions in Dispatcher and DeferredDispatcher -- +-------------------------------------------------------------------------------- + +-- | A version of "Control.Distributed.Process.ManagedProcess.Server.handleCall" +-- that takes a handler which executes in 'RestrictedProcess'. +-- +handleCall :: forall s a b . (Serializable a, Serializable b) + => (a -> RestrictedProcess s (Result b)) + -> Dispatcher s +handleCall = handleCallIf $ Server.state (const True) + +-- | A version of "Control.Distributed.Process.ManagedProcess.Server.handleCallIf" +-- that takes a handler which executes in 'RestrictedProcess'. +-- +handleCallIf :: forall s a b . (Serializable a, Serializable b) + => Condition s a + -> (a -> RestrictedProcess s (Result b)) + -> Dispatcher s +handleCallIf cond h = Server.handleCallIf cond (wrapCall h) + +-- | A version of "Control.Distributed.Process.ManagedProcess.Server.handleCast" +-- that takes a handler which executes in 'RestrictedProcess'. +-- +handleCast :: forall s a . (Serializable a) + => (a -> RestrictedProcess s RestrictedAction) + -> Dispatcher s +handleCast = handleCastIf (Server.state (const True)) + +-- | A version of "Control.Distributed.Process.ManagedProcess.Server.handleCastIf" +-- that takes a handler which executes in 'RestrictedProcess'. +-- +handleCastIf :: forall s a . (Serializable a) + => Condition s a -- ^ predicate that must be satisfied for the handler to run + -> (a -> RestrictedProcess s RestrictedAction) + -- ^ an action yielding function over the process state and input message + -> Dispatcher s +handleCastIf cond h = Server.handleCastIf cond (wrapHandler h) + +-- | A version of "Control.Distributed.Process.ManagedProcess.Server.handleInfo" +-- that takes a handler which executes in 'RestrictedProcess'. +-- +handleInfo :: forall s a. (Serializable a) + => (a -> RestrictedProcess s RestrictedAction) + -> DeferredDispatcher s +-- cast and info look the same to a restricted process +handleInfo h = Server.handleInfo (wrapHandler h) + +-- | Handle exit signals +handleExit :: forall s a. (Serializable a) + => (a -> RestrictedProcess s RestrictedAction) + -> ExitSignalDispatcher s +handleExit h = Server.handleExit $ \_ s a -> wrapHandler h s a + +-- | Handle timeouts +handleTimeout :: forall s . (Delay -> RestrictedProcess s RestrictedAction) + -> TimeoutHandler s +handleTimeout h = \s d -> do + (r, s') <- runRestricted s (h d) + case r of + RestrictedContinue -> Server.continue s' + (RestrictedTimeout i) -> Server.timeoutAfter i s' + (RestrictedHibernate i) -> Server.hibernate i s' + (RestrictedStop r') -> Server.stop r' + +-------------------------------------------------------------------------------- +-- Implementation -- +-------------------------------------------------------------------------------- + +wrapHandler :: forall s a . (Serializable a) + => (a -> RestrictedProcess s RestrictedAction) + -> ActionHandler s a +wrapHandler h s a = do + (r, s') <- runRestricted s (h a) + case r of + RestrictedContinue -> Server.continue s' + (RestrictedTimeout i) -> Server.timeoutAfter i s' + (RestrictedHibernate i) -> Server.hibernate i s' + (RestrictedStop r') -> Server.stop r' + +wrapCall :: forall s a b . (Serializable a, Serializable b) + => (a -> RestrictedProcess s (Result b)) + -> CallHandler s a b +wrapCall h s a = do + (r, s') <- runRestricted s (h a) + case r of + (Reply r') -> Server.reply r' s' + (Timeout i r') -> Server.timeoutAfter i s' >>= Server.replyWith r' + (Hibernate i r') -> Server.hibernate i s' >>= Server.replyWith r' + (Stop r'' ) -> Server.stop r'' >>= Server.noReply + +runRestricted :: s -> RestrictedProcess s a -> Process (a, s) +runRestricted state proc = ST.runStateT (unRestricted proc) state + +-- | TODO MonadTrans instance? lift :: (Monad m) => m a -> t m a +lift :: Process a -> RestrictedProcess s a +lift p = RestrictedProcess $ ST.lift p diff --git a/packages/distributed-process-client-server/src/Control/Distributed/Process/ManagedProcess/Timer.hs b/packages/distributed-process-client-server/src/Control/Distributed/Process/ManagedProcess/Timer.hs new file mode 100644 index 00000000..092f4232 --- /dev/null +++ b/packages/distributed-process-client-server/src/Control/Distributed/Process/ManagedProcess/Timer.hs @@ -0,0 +1,187 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Distributed.Process.ManagedProcess.Timer +-- Copyright : (c) Tim Watson 2017 +-- License : BSD3 (see the file LICENSE) +-- +-- Maintainer : Tim Watson +-- Stability : experimental +-- Portability : non-portable (requires concurrency) +-- +-- This module provides a wrap around a simple 'Timer' that can be started, +-- stopped, reset, cleared, and read. A convenient function is provided for +-- creating a @Match@ expression for the timer. +-- +-- [Notes] +-- +-- The timers defined in this module are based on a @TVar Bool@. When the +-- client program is @-threaded@ (i.e. @rtsSupportsBoundThreads == True@), then +-- the timers are set using @registerDelay@, which is very efficient and relies +-- only no the RTS IO Manager. When we're not @-threaded@, we fall back to using +-- "Control.Distributed.Process.Extras.Timer" to set the @TVar@, which has much +-- the same effect, but requires us to spawn a process to handle setting the +-- @TVar@ - a process which could theoretically die before setting the variable. +-- +module Control.Distributed.Process.ManagedProcess.Timer + ( Timer(timerDelay) + , TimerKey + , delayTimer + , startTimer + , stopTimer + , resetTimer + , clearTimer + , matchTimeout + , matchKey + , matchRun + , isActive + , readTimer + , TimedOut(..) + ) where + +import Control.Concurrent (rtsSupportsBoundThreads) +import Control.Concurrent.STM hiding (check) +import Control.Distributed.Process + ( matchSTM + , Process + , ProcessId + , Match + , Message + , liftIO + ) +import qualified Control.Distributed.Process as P + ( liftIO + ) +import Control.Distributed.Process.Extras.Time (asTimeout, Delay(..)) +import Control.Distributed.Process.Extras.Timer + ( cancelTimer + , runAfter + , TimerRef + ) +import Data.Binary (Binary) +import Data.Maybe (isJust, fromJust) +import Data.Typeable (Typeable) +import GHC.Conc (registerDelay) +import GHC.Generics + +-------------------------------------------------------------------------------- +-- Timeout Management -- +-------------------------------------------------------------------------------- + +-- | A key for storing timers in prioritised process backing state. +type TimerKey = Int + +-- | Used during STM reads on Timers and to implement blocking. Since timers +-- can be associated with a "TimerKey", the second constructor for this type +-- yields a key indicating whic "Timer" it refers to. Note that the user is +-- responsible for establishing and maintaining the mapping between @Timer@s +-- and their keys. +data TimedOut = TimedOut | Yield TimerKey + deriving (Eq, Show, Typeable, Generic) +instance Binary TimedOut where + +-- | We hold timers in 2 states, each described by a Delay. +-- isActive = isJust . mtSignal +-- the TimerRef is optional since we only use the Timer module from extras +-- when we're unable to registerDelay (i.e. not running under -threaded) +data Timer = Timer { timerDelay :: Delay + , mtPidRef :: Maybe TimerRef + , mtSignal :: Maybe (TVar Bool) + } + +-- | @True@ if a @Timer@ is currently active. +isActive :: Timer -> Bool +isActive = isJust . mtSignal + +-- | Creates a default @Timer@ which is inactive. +delayTimer :: Delay -> Timer +delayTimer d = Timer d noPid noTVar + where + noPid = Nothing :: Maybe ProcessId + noTVar = Nothing :: Maybe (TVar Bool) + +-- | Starts a @Timer@ +-- Will use the GHC @registerDelay@ API if @rtsSupportsBoundThreads == True@ +startTimer :: Delay -> Process Timer +startTimer d + | Delay t <- d = establishTimer t + | otherwise = return $ delayTimer d + where + establishTimer t' + | rtsSupportsBoundThreads = do sig <- liftIO $ registerDelay (asTimeout t') + return Timer { timerDelay = d + , mtPidRef = Nothing + , mtSignal = Just sig + } + | otherwise = do + tSig <- liftIO $ newTVarIO False + -- NB: runAfter spawns a process, which is defined in terms of + -- expectTimeout (asTimeout t) :: Process (Maybe CancelTimer) + -- + tRef <- runAfter t' $ P.liftIO $ atomically $ writeTVar tSig True + return Timer { timerDelay = d + , mtPidRef = Just tRef + , mtSignal = Just tSig + } + +-- | Stops a previously started @Timer@. Has no effect if the @Timer@ is inactive. +stopTimer :: Timer -> Process Timer +stopTimer t@Timer{..} = do + clearTimer mtPidRef + return t { mtPidRef = Nothing + , mtSignal = Nothing + } + +-- | Clears and restarts a @Timer@. +resetTimer :: Timer -> Delay -> Process Timer +resetTimer Timer{..} d = clearTimer mtPidRef >> startTimer d + +-- | Clears/cancels a running timer. Has no effect if the @Timer@ is inactive. +clearTimer :: Maybe TimerRef -> Process () +clearTimer ref + | isJust ref = cancelTimer (fromJust ref) + | otherwise = return () + +-- | Creates a @Match@ for a given timer, for use with Cloud Haskell's messaging +-- primitives for selective receives. +matchTimeout :: Timer -> [Match (Either TimedOut Message)] +matchTimeout t@Timer{..} + | isActive t = [ matchSTM (readTimer $ fromJust mtSignal) + (return . Left) ] + | otherwise = [] + +-- | Create a match expression for a given @Timer@. When the timer expires +-- (i.e. the "TVar Bool" is set to @True@), the "Match" will return @Yield i@, +-- where @i@ is the given "TimerKey". +matchKey :: TimerKey -> Timer -> [Match (Either TimedOut Message)] +matchKey i t@Timer{..} + | isActive t = [matchSTM (readTVar (fromJust mtSignal) >>= \expired -> + if expired then return (Yield i) else retry) + (return . Left)] + | otherwise = [] + +-- | As "matchKey", but instead of a returning @Yield i@, the generated "Match" +-- handler evaluates the first argument - and expression from "TimerKey" to +-- @Process Message@ - to determine its result. +matchRun :: (TimerKey -> Process Message) + -> TimerKey + -> Timer + -> [Match Message] +matchRun f k t@Timer{..} + | isActive t = [matchSTM (readTVar (fromJust mtSignal) >>= \expired -> + if expired then return k else retry) f] + | otherwise = [] + +-- | Reads a given @TVar Bool@ for a timer, and returns @STM TimedOut@ once the +-- variable is set to true. Will @retry@ in the meanwhile. +readTimer :: TVar Bool -> STM TimedOut +readTimer t = do + expired <- readTVar t + if expired then return TimedOut + else retry diff --git a/packages/distributed-process-client-server/src/Control/Distributed/Process/ManagedProcess/UnsafeClient.hs b/packages/distributed-process-client-server/src/Control/Distributed/Process/ManagedProcess/UnsafeClient.hs new file mode 100644 index 00000000..5c9b5eb4 --- /dev/null +++ b/packages/distributed-process-client-server/src/Control/Distributed/Process/ManagedProcess/UnsafeClient.hs @@ -0,0 +1,197 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE LiberalTypeSynonyms #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Distributed.Process.ManagedProcess.UnsafeClient +-- Copyright : (c) Tim Watson 2012 - 2017 +-- License : BSD3 (see the file LICENSE) +-- +-- Maintainer : Tim Watson +-- Stability : experimental +-- Portability : non-portable (requires concurrency) +-- +-- Unsafe variant of the /Managed Process Client API/. This module implements +-- the client portion of a Managed Process using the unsafe variants of cloud +-- haskell's messaging primitives. It relies on the -extras implementation of +-- @UnsafePrimitives@, which forces evaluation for types that provide an +-- @NFData@ instance. Direct use of the underlying unsafe primitives (from +-- the distributed-process library) without @NFData@ instances is unsupported. +-- +-- IMPORTANT NOTE: As per the platform documentation, it is not possible to +-- /guarantee/ that an @NFData@ instance will force evaluation in the same way +-- that a @Binary@ instance would (when encoding to a byte string). Please read +-- the unsafe primitives documentation carefully and make sure you know what +-- you're doing. You have been warned. +-- +-- See "Control.Distributed.Process.Extras". +-- See "Control.Distributed.Process.Extras.UnsafePrimitives". +-- See "Control.Distributed.Process.UnsafePrimitives". +----------------------------------------------------------------------------- + +-- TODO: This module is basically cut+paste duplicaton of the /safe/ Client - fix +-- Caveats... we've got to support two different type constraints, somehow, so +-- that the correct implementation gets used depending on whether or not we're +-- passing NFData or just Binary instances... + +module Control.Distributed.Process.ManagedProcess.UnsafeClient + ( -- * Unsafe variants of the Client API + sendControlMessage + , shutdown + , call + , safeCall + , tryCall + , callTimeout + , flushPendingCalls + , callAsync + , cast + , callChan + , syncCallChan + , syncSafeCallChan + ) where + +import Control.Distributed.Process + ( Process + , ProcessId + , ReceivePort + , newChan + , matchChan + , match + , die + , terminate + , receiveTimeout + , unsafeSendChan + , getSelfPid + , catchesExit + , handleMessageIf + ) +import Control.Distributed.Process.Async + ( Async + , async + , task + ) +import Control.Distributed.Process.Extras + ( awaitResponse + , Addressable + , Routable(..) + , NFSerializable + , ExitReason(..) + , Shutdown(..) + ) +import Control.Distributed.Process.ManagedProcess.Internal.Types + ( Message(CastMessage, ChanMessage) + , CallResponse(..) + , ControlPort(..) + , unsafeInitCall + , waitResponse + ) +import Control.Distributed.Process.Extras.Time + ( TimeInterval + , asTimeout + ) +import Control.Distributed.Process.Serializable hiding (SerializableDict) +import Data.Maybe (fromJust) + +-- | Send a control message over a 'ControlPort'. This version of +-- @shutdown@ uses /unsafe primitives/. +-- +sendControlMessage :: Serializable m => ControlPort m -> m -> Process () +sendControlMessage cp m = unsafeSendChan (unPort cp) (CastMessage m) + +-- | Send a signal instructing the process to terminate. This version of +-- @shutdown@ uses /unsafe primitives/. +shutdown :: ProcessId -> Process () +shutdown pid = cast pid Shutdown + +-- | Make a synchronous call - uses /unsafe primitives/. +call :: forall s a b . (Addressable s, NFSerializable a, NFSerializable b) + => s -> a -> Process b +call sid msg = unsafeInitCall sid msg >>= waitResponse Nothing >>= decodeResult + where decodeResult (Just (Right r)) = return r + decodeResult (Just (Left err)) = die err + decodeResult Nothing {- the impossible happened -} = terminate + +-- | Safe version of 'call' that returns information about the error +-- if the operation fails - uses /unsafe primitives/. +safeCall :: forall s a b . (Addressable s, NFSerializable a, NFSerializable b) + => s -> a -> Process (Either ExitReason b) +safeCall s m = do + us <- getSelfPid + (fmap fromJust (unsafeInitCall s m >>= waitResponse Nothing) :: Process (Either ExitReason b)) + `catchesExit` [\pid msg -> handleMessageIf msg (weFailed pid us) + (return . Left)] + + where + + weFailed a b (ExitOther _) = a == b + weFailed _ _ _ = False + +-- | Version of 'safeCall' that returns 'Nothing' if the operation fails. +-- Uses /unsafe primitives/. +tryCall :: forall s a b . (Addressable s, NFSerializable a, NFSerializable b) + => s -> a -> Process (Maybe b) +tryCall s m = unsafeInitCall s m >>= waitResponse Nothing >>= decodeResult + where decodeResult (Just (Right r)) = return $ Just r + decodeResult _ = return Nothing + +-- | Make a synchronous call, but timeout and return @Nothing@ if a reply +-- is not received within the specified time interval - uses /unsafe primitives/. +-- +callTimeout :: forall s a b . (Addressable s, NFSerializable a, NFSerializable b) + => s -> a -> TimeInterval -> Process (Maybe b) +callTimeout s m d = unsafeInitCall s m >>= waitResponse (Just d) >>= decodeResult + where decodeResult :: (NFSerializable b) + => Maybe (Either ExitReason b) + -> Process (Maybe b) + decodeResult Nothing = return Nothing + decodeResult (Just (Right result)) = return $ Just result + decodeResult (Just (Left reason)) = die reason + +-- | Block for @TimeInterval@ waiting for any matching @CallResponse@ +flushPendingCalls :: forall b . (NFSerializable b) + => TimeInterval + -> (b -> Process b) + -> Process (Maybe b) +flushPendingCalls d proc = + receiveTimeout (asTimeout d) [ + match (\(CallResponse (m :: b) _) -> proc m) + ] + +-- | Invokes 'call' /out of band/, and returns an "async handle." +-- Uses /unsafe primitives/. +-- +callAsync :: forall s a b . (Addressable s, NFSerializable a, NFSerializable b) + => s -> a -> Process (Async b) +callAsync server msg = async $ task $ call server msg + +-- | Sends a /cast/ message to the server identified by @server@ - uses /unsafe primitives/. +-- +cast :: forall a m . (Addressable a, NFSerializable m) + => a -> m -> Process () +cast server msg = unsafeSendTo server ((CastMessage msg) :: Message m ()) + +-- | Sends a /channel/ message to the server and returns a @ReceivePort@ - uses /unsafe primitives/. +callChan :: forall s a b . (Addressable s, NFSerializable a, NFSerializable b) + => s -> a -> Process (ReceivePort b) +callChan server msg = do + (sp, rp) <- newChan + unsafeSendTo server ((ChanMessage msg sp) :: Message a b) + return rp + +-- | A synchronous version of 'callChan'. +syncCallChan :: forall s a b . (Addressable s, NFSerializable a, NFSerializable b) + => s -> a -> Process b +syncCallChan server msg = do + r <- syncSafeCallChan server msg + case r of + Left e -> die e + Right r' -> return r' + +-- | A safe version of 'syncCallChan', which returns @Left ExitReason@ if the +-- call fails. +syncSafeCallChan :: forall s a b . (Addressable s, NFSerializable a, NFSerializable b) + => s -> a -> Process (Either ExitReason b) +syncSafeCallChan server msg = do + rp <- callChan server msg + awaitResponse server [ matchChan rp (return . Right) ] diff --git a/packages/distributed-process-client-server/tests/Counter.hs b/packages/distributed-process-client-server/tests/Counter.hs new file mode 100644 index 00000000..3f0a13ad --- /dev/null +++ b/packages/distributed-process-client-server/tests/Counter.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns #-} + +module Counter + ( startCounter, + getCount, + incCount, + resetCount, + wait, + waitTimeout + ) where + +import Control.Distributed.Process hiding (call) +import Control.Distributed.Process.Async +import Control.Distributed.Process.Extras +import Control.Distributed.Process.Extras.Time +import Control.Distributed.Process.ManagedProcess +import Data.Binary +import Data.Typeable (Typeable) + +import GHC.Generics + +-------------------------------------------------------------------------------- +-- Types -- +-------------------------------------------------------------------------------- + +-- Call and Cast request types. Response types are unnecessary as the GenProcess +-- API uses the Async API, which in turn guarantees that an async handle can +-- /only/ give back a reply for that *specific* request through the use of an +-- anonymous middle-man (as the sender and receiver in our case). + +data Increment = Increment + deriving (Typeable, Generic, Eq, Show) +instance Binary Increment where + +data Fetch = Fetch + deriving (Typeable, Generic, Eq, Show) +instance Binary Fetch where + +data Reset = Reset + deriving (Typeable, Generic, Eq, Show) +instance Binary Reset where + +type State = Int + +-------------------------------------------------------------------------------- +-- API -- +-------------------------------------------------------------------------------- + +-- | Increment count +incCount :: ProcessId -> Process Int +incCount sid = call sid Increment + +-- | Get the current count - this is replicating what 'call' actually does +getCount :: ProcessId -> Process Int +getCount sid = call sid Fetch + +-- | Reset the current count +resetCount :: ProcessId -> Process () +resetCount sid = cast sid Reset + +-- | Start a counter server +startCounter :: Int -> Process ProcessId +startCounter startCount = + let server = serverDefinition + in spawnLocal $ serve startCount init' server + where init' :: InitHandler Int Int + init' count = return $ InitOk count Infinity + +-------------------------------------------------------------------------------- +-- Implementation -- +-------------------------------------------------------------------------------- + +serverDefinition :: ProcessDefinition State +serverDefinition = defaultProcess { + apiHandlers = [ + handleCallIf (condition (\count Increment -> count >= 10))-- invariant + (\_ (_ :: Increment) -> haltMaxCount) + + , handleCall handleIncrement + , handleCall (\count Fetch -> reply count count) + , handleCast (\_ Reset -> continue 0) + ] + } :: ProcessDefinition State + +haltMaxCount :: Reply Int State +haltMaxCount = haltNoReply_ (ExitOther "Count > 10") + +handleIncrement :: CallHandler State Increment Int +handleIncrement count Increment = + let next = count + 1 in continue next >>= replyWith next diff --git a/packages/distributed-process-client-server/tests/ManagedProcessCommon.hs b/packages/distributed-process-client-server/tests/ManagedProcessCommon.hs new file mode 100644 index 00000000..1ccfc1c0 --- /dev/null +++ b/packages/distributed-process-client-server/tests/ManagedProcessCommon.hs @@ -0,0 +1,392 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RecordWildCards #-} + +module ManagedProcessCommon where + +import Control.Concurrent.MVar (MVar) +import Control.Concurrent.STM.TQueue + ( newTQueueIO + , readTQueue + , writeTQueue + , TQueue + ) +import Control.Distributed.Process hiding (call, send) +import Control.Distributed.Process.Extras hiding (monitor) +import qualified Control.Distributed.Process as P +import Control.Distributed.Process.SysTest.Utils +import Control.Distributed.Process.Extras.Time +import Control.Distributed.Process.Extras.Timer +import Control.Distributed.Process.Async +import Control.Distributed.Process.ManagedProcess +import qualified Control.Distributed.Process.ManagedProcess.UnsafeClient as Unsafe +import Control.Distributed.Process.Serializable() + +import TestUtils + +type Launcher a = a -> Process (ProcessId, MVar ExitReason) + +explodingTestProcess :: ProcessId -> ProcessDefinition () +explodingTestProcess pid = + statelessProcess { + apiHandlers = [ + handleCall_ (\(s :: String) -> + (die s) :: Process String) + , handleCast (\_ (i :: Int) -> + getSelfPid >>= \p -> die (p, i)) + ] + , exitHandlers = [ + handleExit (\_ s (m :: String) -> do send pid (m :: String) + continue s) + , handleExit (\_ s m@((_ :: ProcessId), + (_ :: Int)) -> P.send pid m >> continue s) + ] + } + +standardTestServer :: UnhandledMessagePolicy -> ProcessDefinition () +standardTestServer policy = + statelessProcess { + apiHandlers = [ + -- note: state is passed here, as a 'stateless' process is + -- in fact process definition whose state is () + + handleCastIf (input (\msg -> msg == "stop")) + (\_ _ -> stop ExitNormal) + + , handleCall (\s' (m :: String) -> reply m s') + , handleCall_ (\(n :: Int) -> return (n * 2)) -- "stateless" + + , handleCall (\s' (_ :: Delay) -> (reject s' "invalid-call") :: Reply () ()) + + , handleCast (\s' ("ping", pid :: ProcessId) -> + send pid "pong" >> continue s') + , handleCastIf_ (input (\(c :: String, _ :: Delay) -> c == "timeout")) + (\("timeout", d) -> timeoutAfter_ d) + + , handleCast_ (\("hibernate", d :: TimeInterval) -> hibernate_ d) + ] + , unhandledMessagePolicy = policy + , timeoutHandler = \_ _ -> stop $ ExitOther "timeout" + } + +wrap :: (Process (ProcessId, MVar ExitReason)) -> Launcher a +wrap it = \_ -> do it + +data StmServer = StmServer { serverPid :: ProcessId + , writerChan :: TQueue String + , readerChan :: TQueue String + } + +instance Resolvable StmServer where + resolve = return . Just . serverPid + +echoStm :: StmServer -> String -> Process (Either ExitReason String) +echoStm StmServer{..} = callSTM serverPid + (writeTQueue writerChan) + (readTQueue readerChan) + +launchEchoServer :: CallHandler () String String -> Process StmServer +launchEchoServer handler = do + (inQ, replyQ) <- liftIO $ do + cIn <- newTQueueIO + cOut <- newTQueueIO + return (cIn, cOut) + + let procDef = statelessProcess { + externHandlers = [ + handleCallExternal + (readTQueue inQ) + (writeTQueue replyQ) + handler + ] + } + + pid <- spawnLocal $ serve () (statelessInit Infinity) procDef + return $ StmServer pid inQ replyQ + +deferredResponseServer :: Process ProcessId +deferredResponseServer = + let procDef = defaultProcess { + apiHandlers = [ + handleCallFrom (\r s (m :: String) -> noReply_ ((r, m):s) ) + ] + , infoHandlers = [ + handleInfo (\s () -> (mapM_ (\t -> replyTo (fst t) (snd t)) s) >> continue []) + ] + } :: ProcessDefinition [(CallRef String, String)] + in spawnLocal $ serve [] (\s -> return $ InitOk s Infinity) procDef + +-- common test cases + +testDeferredCallResponse :: TestResult (AsyncResult String) -> Process () +testDeferredCallResponse result = do + pid <- deferredResponseServer + r <- async $ task $ (call pid "Hello There" :: Process String) + + sleep $ seconds 2 + AsyncPending <- poll r + + send pid () + wait r >>= stash result + +testBasicCall :: Launcher () -> TestResult (Maybe String) -> Process () +testBasicCall launch result = do + (pid, _) <- launch () + callTimeout pid "foo" (within 5 Seconds) >>= stash result + +testUnsafeBasicCall :: Launcher () -> TestResult (Maybe String) -> Process () +testUnsafeBasicCall launch result = do + (pid, _) <- launch () + Unsafe.callTimeout pid "foo" (within 5 Seconds) >>= stash result + +testBasicCall_ :: Launcher () -> TestResult (Maybe Int) -> Process () +testBasicCall_ launch result = do + (pid, _) <- launch () + callTimeout pid (2 :: Int) (within 5 Seconds) >>= stash result + +testUnsafeBasicCall_ :: Launcher () -> TestResult (Maybe Int) -> Process () +testUnsafeBasicCall_ launch result = do + (pid, _) <- launch () + Unsafe.callTimeout pid (2 :: Int) (within 5 Seconds) >>= stash result + +testBasicCast :: Launcher () -> TestResult (Maybe String) -> Process () +testBasicCast launch result = do + self <- getSelfPid + (pid, _) <- launch () + cast pid ("ping", self) + expectTimeout (after 3 Seconds) >>= stash result + +testUnsafeBasicCast :: Launcher () -> TestResult (Maybe String) -> Process () +testUnsafeBasicCast launch result = do + self <- getSelfPid + (pid, _) <- launch () + Unsafe.cast pid ("ping", self) + expectTimeout (after 3 Seconds) >>= stash result + +testControlledTimeout :: Launcher () -> TestResult (Maybe ExitReason) -> Process () +testControlledTimeout launch result = do + (pid, exitReason) <- launch () + cast pid ("timeout", Delay $ within 1 Seconds) + waitForExit exitReason >>= stash result + +testUnsafeControlledTimeout :: Launcher () -> TestResult (Maybe ExitReason) -> Process () +testUnsafeControlledTimeout launch result = do + (pid, exitReason) <- launch () + Unsafe.cast pid ("timeout", Delay $ within 1 Seconds) + waitForExit exitReason >>= stash result + +testTerminatePolicy :: Launcher () -> TestResult (Maybe ExitReason) -> Process () +testTerminatePolicy launch result = do + (pid, exitReason) <- launch () + send pid ("UNSOLICITED_MAIL", 500 :: Int) + waitForExit exitReason >>= stash result + +testUnsafeTerminatePolicy :: Launcher () -> TestResult (Maybe ExitReason) -> Process () +testUnsafeTerminatePolicy launch result = do + (pid, exitReason) <- launch () + send pid ("UNSOLICITED_MAIL", 500 :: Int) + waitForExit exitReason >>= stash result + +testDropPolicy :: Launcher () -> TestResult (Maybe ExitReason) -> Process () +testDropPolicy launch result = do + (pid, exitReason) <- launch () + + send pid ("UNSOLICITED_MAIL", 500 :: Int) + + sleep $ milliSeconds 250 + mref <- monitor pid + + cast pid "stop" + + r <- receiveTimeout (after 10 Seconds) [ + matchIf (\(ProcessMonitorNotification ref _ _) -> ref == mref) + (\(ProcessMonitorNotification _ _ r) -> + case r of + DiedUnknownId -> stash result Nothing + _ -> waitForExit exitReason >>= stash result) + ] + case r of + Nothing -> stash result Nothing + _ -> return () + +testUnsafeDropPolicy :: Launcher () -> TestResult (Maybe ExitReason) -> Process () +testUnsafeDropPolicy launch result = do + (pid, exitReason) <- launch () + + send pid ("UNSOLICITED_MAIL", 500 :: Int) + + sleep $ milliSeconds 250 + mref <- monitor pid + + Unsafe.cast pid "stop" + + r <- receiveTimeout (after 10 Seconds) [ + matchIf (\(ProcessMonitorNotification ref _ _) -> ref == mref) + (\(ProcessMonitorNotification _ _ r) -> + case r of + DiedUnknownId -> stash result Nothing + _ -> waitForExit exitReason >>= stash result) + ] + case r of + Nothing -> stash result Nothing + _ -> return () + +testDeadLetterPolicy :: Launcher ProcessId + -> TestResult (Maybe (String, Int)) + -> Process () +testDeadLetterPolicy launch result = do + self <- getSelfPid + (pid, _) <- launch self + + send pid ("UNSOLICITED_MAIL", 500 :: Int) + cast pid "stop" + + receiveTimeout + (after 5 Seconds) + [ match (\m@(_ :: String, _ :: Int) -> return m) ] >>= stash result + +testUnsafeDeadLetterPolicy :: Launcher ProcessId + -> TestResult (Maybe (String, Int)) + -> Process () +testUnsafeDeadLetterPolicy launch result = do + self <- getSelfPid + (pid, _) <- launch self + + send pid ("UNSOLICITED_MAIL", 500 :: Int) + Unsafe.cast pid "stop" + + receiveTimeout + (after 5 Seconds) + [ match (\m@(_ :: String, _ :: Int) -> return m) ] >>= stash result + +testHibernation :: Launcher () -> TestResult Bool -> Process () +testHibernation launch result = do + (pid, _) <- launch () + mref <- monitor pid + + cast pid ("hibernate", (within 3 Seconds)) + cast pid "stop" + + -- the process mustn't stop whilst it's supposed to be hibernating + r <- receiveTimeout (after 2 Seconds) [ + matchIf (\(ProcessMonitorNotification ref _ _) -> ref == mref) + (\_ -> return ()) + ] + case r of + Nothing -> kill pid "done" >> stash result True + Just _ -> stash result False + +testUnsafeHibernation :: Launcher () -> TestResult Bool -> Process () +testUnsafeHibernation launch result = do + (pid, _) <- launch () + mref <- monitor pid + + Unsafe.cast pid ("hibernate", (within 3 Seconds)) + Unsafe.cast pid "stop" + + -- the process mustn't stop whilst it's supposed to be hibernating + r <- receiveTimeout (after 2 Seconds) [ + matchIf (\(ProcessMonitorNotification ref _ _) -> ref == mref) + (\_ -> return ()) + ] + case r of + Nothing -> kill pid "done" >> stash result True + Just _ -> stash result False + +testKillMidCall :: Launcher () -> TestResult Bool -> Process () +testKillMidCall launch result = do + (pid, _) <- launch () + cast pid ("hibernate", (within 3 Seconds)) + callAsync pid "hello-world" >>= cancelWait >>= unpack result pid + where unpack :: TestResult Bool -> ProcessId -> AsyncResult () -> Process () + unpack res sid AsyncCancelled = kill sid "stop" >> stash res True + unpack res sid _ = kill sid "stop" >> stash res False + +testUnsafeKillMidCall :: Launcher () -> TestResult Bool -> Process () +testUnsafeKillMidCall launch result = do + (pid, _) <- launch () + Unsafe.cast pid ("hibernate", (within 3 Seconds)) + Unsafe.callAsync pid "hello-world" >>= cancelWait >>= unpack result pid + where unpack :: TestResult Bool -> ProcessId -> AsyncResult () -> Process () + unpack res sid AsyncCancelled = kill sid "stop" >> stash res True + unpack res sid _ = kill sid "stop" >> stash res False + +testSimpleErrorHandling :: Launcher ProcessId + -> TestResult (Maybe ExitReason) + -> Process () +testSimpleErrorHandling launch result = do + self <- getSelfPid + (pid, exitReason) <- launch self + register "SUT" pid + sleep $ seconds 2 + + -- this should be *altered* because of the exit handler + Nothing <- callTimeout pid "foobar" (within 1 Seconds) :: Process (Maybe String) + + Right _ <- awaitResponse pid [ + matchIf (\(s :: String) -> s == "foobar") + (\s -> return (Right s) :: Process (Either ExitReason String)) + ] + + shutdown pid + waitForExit exitReason >>= stash result + +testUnsafeSimpleErrorHandling :: Launcher ProcessId + -> TestResult (Maybe ExitReason) + -> Process () +testUnsafeSimpleErrorHandling launch result = do + self <- getSelfPid + (pid, exitReason) <- launch self + + -- this should be *altered* because of the exit handler + Nothing <- Unsafe.callTimeout pid "foobar" (within 1 Seconds) :: Process (Maybe String) + "foobar" <- expect + + Unsafe.shutdown pid + waitForExit exitReason >>= stash result + +testAlternativeErrorHandling :: Launcher ProcessId + -> TestResult (Maybe ExitReason) + -> Process () +testAlternativeErrorHandling launch result = do + self <- getSelfPid + (pid, exitReason) <- launch self + + -- this should be ignored/altered because of the second exit handler + cast pid (42 :: Int) + (Just True) <- receiveTimeout (after 2 Seconds) [ + matchIf (\((p :: ProcessId), (i :: Int)) -> p == pid && i == 42) + (\_ -> return True) + ] + + shutdown pid + waitForExit exitReason >>= stash result + +testUnsafeAlternativeErrorHandling :: Launcher ProcessId + -> TestResult (Maybe ExitReason) + -> Process () +testUnsafeAlternativeErrorHandling launch result = do + self <- getSelfPid + (pid, exitReason) <- launch self + + -- this should be ignored/altered because of the second exit handler + Unsafe.cast pid (42 :: Int) + (Just True) <- receiveTimeout (after 2 Seconds) [ + matchIf (\((p :: ProcessId), (i :: Int)) -> p == pid && i == 42) + (\_ -> return True) + ] + + Unsafe.shutdown pid + waitForExit exitReason >>= stash result + +testServerRejectsMessage :: Launcher ProcessId + -> TestResult ExitReason + -> Process () +testServerRejectsMessage launch result = do + self <- getSelfPid + (pid, _) <- launch self + + -- server is configured to reject (m :: Delay) + Left res <- safeCall pid Infinity :: Process (Either ExitReason ()) + stash result res diff --git a/packages/distributed-process-client-server/tests/MathsDemo.hs b/packages/distributed-process-client-server/tests/MathsDemo.hs new file mode 100644 index 00000000..4c24f888 --- /dev/null +++ b/packages/distributed-process-client-server/tests/MathsDemo.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +module MathsDemo + ( add + , divide + , launchMathServer + , DivByZero(..) + , Add(..) + ) where + +import Control.Distributed.Process hiding (call) +import Control.Distributed.Process.Extras +import Control.Distributed.Process.Extras.Time +import Control.Distributed.Process.ManagedProcess + +import Data.Binary (Binary(..)) +import Data.Typeable (Typeable) + +data Add = Add Double Double deriving (Typeable) +data Divide = Divide Double Double deriving (Typeable) +data DivByZero = DivByZero deriving (Typeable, Eq) + +instance Binary Add where + put (Add x y) = put x >> put y + get = Add <$> get <*> get + +instance Binary Divide where + put (Divide x y) = put x >> put y + get = Divide <$> get <*> get + +instance Binary DivByZero where + put DivByZero = return () + get = return DivByZero + +-- public API + +add :: ProcessId -> Double -> Double -> Process Double +add sid x y = call sid (Add x y) + +divide :: ProcessId -> Double -> Double + -> Process (Either DivByZero Double) +divide sid x y = call sid (Divide x y ) + +launchMathServer :: Process ProcessId +launchMathServer = + let server = statelessProcess { + apiHandlers = [ + handleCall_ (\(Add x y) -> return (x + y)) + , handleCallIf_ (input (\(Divide _ y) -> y /= 0)) handleDivide + , handleCall_ (\(Divide _ _) -> divByZero) + , action (\("stop") -> stop_ ExitNormal) + ] + } + in spawnLocal $ serve () (statelessInit Infinity) server + where handleDivide :: Divide -> Process (Either DivByZero Double) + handleDivide (Divide x y) = return $ Right $ x / y + + divByZero :: Process (Either DivByZero Double) + divByZero = return $ Left DivByZero diff --git a/packages/distributed-process-client-server/tests/SafeCounter.hs b/packages/distributed-process-client-server/tests/SafeCounter.hs new file mode 100644 index 00000000..a6ea9451 --- /dev/null +++ b/packages/distributed-process-client-server/tests/SafeCounter.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveGeneric #-} + +module SafeCounter + ( startCounter, + getCount, + getCountAsync, + incCount, + resetCount, + wait, + waitTimeout, + Fetch(..), + Increment(..), + Reset(..) + ) where + +import Control.Distributed.Process hiding (call, say) +import Control.Distributed.Process.Extras +import Control.Distributed.Process.Async +import Control.Distributed.Process.ManagedProcess + ( ProcessDefinition(..) + , InitHandler + , InitResult(..) + , defaultProcess + , condition + ) +import qualified Control.Distributed.Process.ManagedProcess as ManagedProcess (serve) +import Control.Distributed.Process.ManagedProcess.Client +import Control.Distributed.Process.ManagedProcess.Server.Restricted +import Control.Distributed.Process.Extras.Time +import Control.Distributed.Process.Serializable +import Data.Binary +import Data.Typeable (Typeable) +import GHC.Generics + +-------------------------------------------------------------------------------- +-- Types -- +-------------------------------------------------------------------------------- + +data Increment = Increment + deriving (Show, Typeable, Generic) +instance Binary Increment where + +data Fetch = Fetch + deriving (Show, Typeable, Generic) +instance Binary Fetch where + +data Reset = Reset deriving (Show, Typeable, Generic) +instance Binary Reset where + +-------------------------------------------------------------------------------- +-- API -- +-------------------------------------------------------------------------------- + +-- | Increment count +incCount :: ProcessId -> Process Int +incCount sid = call sid Increment + +-- | Get the current count +getCount :: ProcessId -> Process Int +getCount sid = call sid Fetch + +-- | Get the current count asynchronously +getCountAsync :: ProcessId -> Process (Async Int) +getCountAsync sid = callAsync sid Fetch + +-- | Reset the current count +resetCount :: ProcessId -> Process () +resetCount sid = cast sid Reset + +-- | Start a counter server +startCounter :: Int -> Process ProcessId +startCounter startCount = + let server = serverDefinition + in spawnLocal $ ManagedProcess.serve startCount init' server + where init' :: InitHandler Int Int + init' count = return $ InitOk count Infinity + +-------------------------------------------------------------------------------- +-- Implementation -- +-------------------------------------------------------------------------------- + +serverDefinition :: ProcessDefinition Int +serverDefinition = defaultProcess { + apiHandlers = [ + handleCallIf + (condition (\count Increment -> count >= 10)) -- invariant + (\Increment -> halt :: RestrictedProcess Int (Result Int)) + + , handleCall handleIncrement + , handleCall (\Fetch -> getState >>= reply) + , handleCast (\Reset -> putState (0 :: Int) >> continue) + ] + } :: ProcessDefinition Int + +halt :: forall s r . Serializable r => RestrictedProcess s (Result r) +halt = haltNoReply (ExitOther "Count > 10") + +handleIncrement :: Increment -> RestrictedProcess Int (Result Int) +handleIncrement _ = modifyState (+1) >> getState >>= reply + diff --git a/packages/distributed-process-client-server/tests/TestManagedProcess.hs b/packages/distributed-process-client-server/tests/TestManagedProcess.hs new file mode 100644 index 00000000..09fa3ff5 --- /dev/null +++ b/packages/distributed-process-client-server/tests/TestManagedProcess.hs @@ -0,0 +1,380 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards #-} + +module Main where + +import Control.Concurrent.STM (atomically) +import Control.Concurrent.STM.TQueue + ( newTQueueIO + , readTQueue + , writeTQueue + ) +import Control.Concurrent.MVar +import Control.Exception (SomeException) +import Control.Distributed.Process hiding (call, catch) +import Control.Distributed.Process.Async (AsyncResult(AsyncDone)) +import Control.Distributed.Process.Node +import Control.Distributed.Process.Extras hiding (__remoteTable, monitor, send, nsend) +import Control.Distributed.Process.ManagedProcess +import Control.Distributed.Process.SysTest.Utils +import Control.Distributed.Process.Extras.Time +import Control.Distributed.Process.Serializable() + +import MathsDemo +import Counter +import qualified SafeCounter as SafeCounter + +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import TestUtils +import ManagedProcessCommon + +import qualified Network.Transport as NT +import Control.Monad (void) +import Control.Monad.Catch (catch) + +-- utilities + +server :: Process (ProcessId, MVar ExitReason) +server = mkServer Terminate + +mkServer :: UnhandledMessagePolicy + -> Process (ProcessId, MVar ExitReason) +mkServer policy = + let s = standardTestServer policy + in do + exitReason <- liftIO newEmptyMVar + pid <- spawnLocal $ + catch ((serve () (statelessInit Infinity) s >> stash exitReason ExitNormal) + `catchesExit` [ + (\_ msg -> do + mEx <- unwrapMessage msg :: Process (Maybe ExitReason) + case mEx of + Nothing -> return Nothing + Just r -> fmap Just (stash exitReason r) + ) + ]) + (\(e :: SomeException) -> stash exitReason $ ExitOther (show e)) + return (pid, exitReason) + +explodingServer :: ProcessId + -> Process (ProcessId, MVar ExitReason) +explodingServer pid = + let srv = explodingTestProcess pid + in do + exitReason <- liftIO newEmptyMVar + spid <- spawnLocal $ + catch (serve () (statelessInit Infinity) srv >> stash exitReason ExitNormal) + (\(e :: SomeException) -> stash exitReason $ ExitOther (show e)) + return (spid, exitReason) + +testCallReturnTypeMismatchHandling :: TestResult Bool -> Process () +testCallReturnTypeMismatchHandling result = + let procDef = statelessProcess { + apiHandlers = [ + handleCall (\s (m :: String) -> reply m s) + ] + , unhandledMessagePolicy = Terminate + } in do + pid <- spawnLocal $ serve () (statelessInit Infinity) procDef + res <- safeCall pid "hello buddy" :: Process (Either ExitReason ()) + case res of + Left (ExitOther _) -> stash result True + _ -> stash result False + +testChannelBasedService :: TestResult Bool -> Process () +testChannelBasedService result = + let procDef = statelessProcess { + apiHandlers = [ + handleRpcChan (\p s (m :: String) -> + replyChan p m >> continue s) + ] + } in do + pid <- spawnLocal $ serve () (statelessInit Infinity) procDef + echo <- syncCallChan pid "hello" + stash result (echo == "hello") + kill pid "done" + +testExternalService :: TestResult Bool -> Process () +testExternalService result = do + inChan <- liftIO newTQueueIO + replyQ <- liftIO newTQueueIO + let procDef = statelessProcess { + externHandlers = [ + handleExternal + (readTQueue inChan) + (\s (m :: String) -> do + liftIO $ atomically $ writeTQueue replyQ m + continue s) + ] + } + let txt = "hello 2-way stm foo" + pid <- spawnLocal $ serve () (statelessInit Infinity) procDef + echoTxt <- liftIO $ do + -- firstly we write something that the server can receive + atomically $ writeTQueue inChan txt + -- then sit and wait for it to write something back to us + atomically $ readTQueue replyQ + + stash result (echoTxt == txt) + kill pid "done" + +testExternalCall :: TestResult Bool -> Process () +testExternalCall result = do + let txt = "hello stm-call foo" + srv <- launchEchoServer (\st (msg :: String) -> reply msg st) + echoStm srv txt >>= stash result . (== Right txt) + killProc srv "done" + +testExternalCallHaltingServer :: TestResult Bool -> Process () +testExternalCallHaltingServer result = do + let msg = "foo bar baz" + srv <- launchEchoServer (\_ (_ :: String) -> haltNoReply_ ExitNormal) + echoReply <- echoStm srv msg + case echoReply of + -- sadly, we cannot guarantee that our monitor will be set up fast + -- enough, as per the documentation! + Left (ExitOther reason) -> stash result $ reason `elem` [ "DiedUnknownId" + , "DiedNormal" + ] + (Left ExitNormal) -> stash result False + (Left ExitShutdown) -> stash result False + (Right _) -> stash result False + +-- MathDemo tests + +testAdd :: TestResult Double -> Process () +testAdd result = do + pid <- launchMathServer + add pid 10 10 >>= stash result + kill pid "done" + +testBadAdd :: TestResult Bool -> Process () +testBadAdd result = do + pid <- launchMathServer + res <- safeCall pid (Add 10 10) :: Process (Either ExitReason Int) + stash result (res == (Left $ ExitOther $ "DiedException \"exit-from=" ++ (show pid) ++ "\"")) + +testDivByZero :: TestResult (Either DivByZero Double) -> Process () +testDivByZero result = do + pid <- launchMathServer + divide pid 125 0 >>= stash result + kill pid "done" + +-- SafeCounter tests + +testSafeCounterCurrentState :: ProcessId -> TestResult Int -> Process () +testSafeCounterCurrentState pid result = + SafeCounter.getCount pid >>= stash result + +testSafeCounterIncrement :: ProcessId -> TestResult Int -> Process () +testSafeCounterIncrement pid result = do + 5 <- SafeCounter.getCount pid + SafeCounter.resetCount pid + 1 <- SafeCounter.incCount pid + 2 <- SafeCounter.incCount pid + SafeCounter.getCount pid >>= stash result + +-- Counter tests + +testCounterCurrentState :: TestResult Int -> Process () +testCounterCurrentState result = do + pid <- Counter.startCounter 5 + getCount pid >>= stash result + +testCounterIncrement :: TestResult Bool -> Process () +testCounterIncrement result = do + pid <- Counter.startCounter 1 + n <- getCount pid + 2 <- incCount pid + 3 <- incCount pid + getCount pid >>= \n' -> stash result (n' == (n + 2)) + +testCounterExceedsLimit :: TestResult Bool -> Process () +testCounterExceedsLimit result = do + pid <- Counter.startCounter 1 + mref <- monitor pid + + -- exceed the limit + 9 `times` (void $ incCount pid) + + -- this time we should fail + _ <- (incCount pid) + `catchExit` \_ (_ :: ExitReason) -> return 0 + + r <- receiveWait [ + matchIf (\(ProcessMonitorNotification ref _ _) -> ref == mref) + (\(ProcessMonitorNotification _ _ r') -> return r') + ] + stash result (r /= DiedNormal) + +tests :: NT.Transport -> IO [Test] +tests transport = do + localNode <- newLocalNode transport initRemoteTable + scpid <- newEmptyMVar + _ <- forkProcess localNode $ SafeCounter.startCounter 5 >>= stash scpid + safeCounter <- takeMVar scpid + return [ + testGroup "Basic Client/Server Functionality" [ + testCase "basic call with explicit server reply" + (delayedAssertion + "expected a response from the server" + localNode (Just "foo") (testBasicCall $ wrap server)) + , testCase "basic (unsafe) call with explicit server reply" + (delayedAssertion + "expected a response from the server" + localNode (Just "foo") (testUnsafeBasicCall $ wrap server)) + , testCase "basic call with implicit server reply" + (delayedAssertion + "expected n * 2 back from the server" + localNode (Just 4) (testBasicCall_ $ wrap server)) + , testCase "basic (unsafe) call with implicit server reply" + (delayedAssertion + "expected n * 2 back from the server" + localNode (Just 4) (testUnsafeBasicCall_ $ wrap server)) + , testCase "basic deferred call handling" + (delayedAssertion "expected a response sent via replyTo" + localNode (AsyncDone "Hello There") testDeferredCallResponse) + , testCase "basic cast with manual send and explicit server continue" + (delayedAssertion + "expected pong back from the server" + localNode (Just "pong") (testBasicCast $ wrap server)) + , testCase "basic (unsafe) cast with manual send and explicit server continue" + (delayedAssertion + "expected pong back from the server" + localNode (Just "pong") (testUnsafeBasicCast $ wrap server)) + , testCase "basic channel based rpc" + (delayedAssertion + "expected response back from the server" + localNode True testChannelBasedService) + ] + , testGroup "Unhandled Message Policies" [ + testCase "unhandled input when policy = Terminate" + (delayedAssertion + "expected the server to stop upon receiving unhandled input" + localNode (Just $ ExitOther "UnhandledInput") + (testTerminatePolicy $ wrap server)) + , testCase "(unsafe) unhandled input when policy = Terminate" + (delayedAssertion + "expected the server to stop upon receiving unhandled input" + localNode (Just $ ExitOther "UnhandledInput") + (testUnsafeTerminatePolicy $ wrap server)) + , testCase "unhandled input when policy = Drop" + (delayedAssertion + "expected the server to ignore unhandled input and exit normally" + localNode Nothing (testDropPolicy $ wrap (mkServer Drop))) + , testCase "(unsafe) unhandled input when policy = Drop" + (delayedAssertion + "expected the server to ignore unhandled input and exit normally" + localNode Nothing (testUnsafeDropPolicy $ wrap (mkServer Drop))) + , testCase "unhandled input when policy = DeadLetter" + (delayedAssertion + "expected the server to forward unhandled messages" + localNode (Just ("UNSOLICITED_MAIL", 500 :: Int)) + (testDeadLetterPolicy $ \p -> mkServer (DeadLetter p))) + , testCase "(unsafe) unhandled input when policy = DeadLetter" + (delayedAssertion + "expected the server to forward unhandled messages" + localNode (Just ("UNSOLICITED_MAIL", 500 :: Int)) + (testUnsafeDeadLetterPolicy $ \p -> mkServer (DeadLetter p))) + , testCase "incoming messages are ignored whilst hibernating" + (delayedAssertion + "expected the server to remain in hibernation" + localNode True (testHibernation $ wrap server)) + , testCase "(unsafe) incoming messages are ignored whilst hibernating" + (delayedAssertion + "expected the server to remain in hibernation" + localNode True (testUnsafeHibernation $ wrap server)) + ] + , testGroup "Server Exit Handling" [ + testCase "simple exit handling" + (delayedAssertion "expected handler to catch exception and continue" + localNode Nothing (testSimpleErrorHandling $ explodingServer)) + , testCase "(unsafe) simple exit handling" + (delayedAssertion "expected handler to catch exception and continue" + localNode Nothing (testUnsafeSimpleErrorHandling $ explodingServer)) + , testCase "alternative exit handlers" + (delayedAssertion "expected handler to catch exception and continue" + localNode Nothing (testAlternativeErrorHandling $ explodingServer)) + , testCase "(unsafe) alternative exit handlers" + (delayedAssertion "expected handler to catch exception and continue" + localNode Nothing (testUnsafeAlternativeErrorHandling $ explodingServer)) + ] + , testGroup "Advanced Server Interactions" [ + testCase "taking arbitrary STM actions" + (delayedAssertion + "expected the server to read the STM queue and reply using STM" + localNode True testExternalService) + , testCase "using callSTM to manage non-CH interactions" + (delayedAssertion + "expected the server to reply back via the TQueue" + localNode True testExternalCall) + , testCase "getting error data back from callSTM" + (delayedAssertion + "expected the server to exit with ExitNormal" + localNode True testExternalCallHaltingServer) + , testCase "long running call cancellation" + (delayedAssertion "expected to get AsyncCancelled" + localNode True (testKillMidCall $ wrap server)) + , testCase "(unsafe) long running call cancellation" + (delayedAssertion "expected to get AsyncCancelled" + localNode True (testUnsafeKillMidCall $ wrap server)) + , testCase "server rejects call" + (delayedAssertion "expected server to send CallRejected" + localNode (ExitOther "invalid-call") (testServerRejectsMessage $ wrap server)) + , testCase "invalid return type handling" + (delayedAssertion + "expected response to fail on runtime type verification" + localNode True testCallReturnTypeMismatchHandling) + , testCase "cast and explicit server timeout" + (delayedAssertion + "expected the server to stop after the timeout" + localNode (Just $ ExitOther "timeout") (testControlledTimeout $ wrap server)) + , testCase "(unsafe) cast and explicit server timeout" + (delayedAssertion + "expected the server to stop after the timeout" + localNode (Just $ ExitOther "timeout") (testUnsafeControlledTimeout $ wrap server)) + ] + , testGroup "math server examples" [ + testCase "error (Left) returned from x / 0" + (delayedAssertion + "expected the server to return DivByZero" + localNode (Left DivByZero) testDivByZero) + , testCase "10 + 10 = 20" + (delayedAssertion + "expected the server to return DivByZero" + localNode 20 testAdd) + , testCase "10 + 10 does not evaluate to 10 :: Int at all!" + (delayedAssertion + "expected the server to return ExitOther..." + localNode True testBadAdd) + ] + , testGroup "counter server examples" [ + testCase "initial counter state = 5" + (delayedAssertion + "expected the server to return the initial state of 5" + localNode 5 testCounterCurrentState) + , testCase "increment counter twice" + (delayedAssertion + "expected the server to return the incremented state as 7" + localNode True testCounterIncrement) + , testCase "exceed counter limits" + (delayedAssertion + "expected the server to terminate once the limit was exceeded" + localNode True testCounterExceedsLimit) + ] + , testGroup "safe counter examples" [ + testCase "initial counter state = 5" + (delayedAssertion + "expected the server to return the initial state of 5" + localNode 5 (testSafeCounterCurrentState safeCounter)) + , testCase "increment counter twice" + (delayedAssertion + "expected the server to return the incremented state as 7" + localNode 2 (testSafeCounterIncrement safeCounter)) + ] + ] + +main :: IO () +main = testMain $ tests diff --git a/packages/distributed-process-client-server/tests/TestPrioritisedProcess.hs b/packages/distributed-process-client-server/tests/TestPrioritisedProcess.hs new file mode 100644 index 00000000..8116249e --- /dev/null +++ b/packages/distributed-process-client-server/tests/TestPrioritisedProcess.hs @@ -0,0 +1,633 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} + +module Main where + +import Control.Concurrent.MVar +import Control.Concurrent.STM.TQueue + ( newTQueueIO + , readTQueue + , writeTQueue + ) +import Control.Exception (SomeException) +import Control.DeepSeq (NFData) +import Control.Distributed.Process hiding (call, send, catch, sendChan, wrapMessage) +import Control.Distributed.Process.Node +import Control.Distributed.Process.Extras hiding (__remoteTable, monitor) +import Control.Distributed.Process.Async hiding (check) +import Control.Distributed.Process.ManagedProcess hiding (reject, Message) +import qualified Control.Distributed.Process.ManagedProcess.Server.Priority as P (Message) +import Control.Distributed.Process.ManagedProcess.Server.Priority hiding (Message) +import qualified Control.Distributed.Process.ManagedProcess.Server.Gen as Gen + ( dequeue + , continue + , lift + ) +import Control.Distributed.Process.SysTest.Utils +import Control.Distributed.Process.Extras.Time +import Control.Distributed.Process.Extras.Timer hiding (runAfter) +import Control.Distributed.Process.Serializable() +import Control.Monad +import Control.Monad.Catch (catch) + +import Data.Binary +import Data.Either (rights) +import Data.List (isInfixOf) +import Data.Maybe (isNothing, isJust) +import Data.Typeable (Typeable) + +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import TestUtils +import ManagedProcessCommon + +import qualified Network.Transport as NT + +import GHC.Generics (Generic) + +-- utilities + +server :: Process (ProcessId, (MVar ExitReason)) +server = mkServer Terminate + +mkServer :: UnhandledMessagePolicy + -> Process (ProcessId, (MVar ExitReason)) +mkServer policy = + let s = standardTestServer policy + p = s `prioritised` ([] :: [DispatchPriority ()]) + in do + exitReason <- liftIO $ newEmptyMVar + pid <- spawnLocal $ do + catch ((pserve () (statelessInit Infinity) p >> stash exitReason ExitNormal) + `catchesExit` [ + (\_ msg -> do + mEx <- unwrapMessage msg :: Process (Maybe ExitReason) + case mEx of + Nothing -> return Nothing + Just r -> stash exitReason r >>= return . Just + ) + ]) + (\(e :: SomeException) -> stash exitReason $ ExitOther (show e)) + return (pid, exitReason) + +explodingServer :: ProcessId + -> Process (ProcessId, MVar ExitReason) +explodingServer pid = + let srv = explodingTestProcess pid + pSrv = srv `prioritised` ([] :: [DispatchPriority s]) + in do + exitReason <- liftIO newEmptyMVar + spid <- spawnLocal $ do + catch (pserve () (statelessInit Infinity) pSrv >> stash exitReason ExitNormal) + (\(e :: SomeException) -> do + -- say "died in handler..." + stash exitReason $ ExitOther (show e)) + return (spid, exitReason) + +data GetState = GetState + deriving (Typeable, Generic, Show, Eq) +instance Binary GetState where +instance NFData GetState where + +data MyAlarmSignal = MyAlarmSignal + deriving (Typeable, Generic, Show, Eq) +instance Binary MyAlarmSignal where +instance NFData MyAlarmSignal where + +mkPrioritisedServer :: Process ProcessId +mkPrioritisedServer = + let p = procDef `prioritised` ([ + prioritiseInfo_ (\MyAlarmSignal -> setPriority 10) + , prioritiseCast_ (\(_ :: String) -> setPriority 2) + , prioritiseCall_ (\(cmd :: String) -> (setPriority (length cmd)) :: Priority ()) + ] :: [DispatchPriority [Either MyAlarmSignal String]] + ) :: PrioritisedProcessDefinition [(Either MyAlarmSignal String)] + in spawnLocal $ pserve () (initWait Infinity) p + where + initWait :: Delay + -> InitHandler () [Either MyAlarmSignal String] + initWait d () = do + () <- expect + return $ InitOk [] d + + procDef :: ProcessDefinition [(Either MyAlarmSignal String)] + procDef = + defaultProcess { + apiHandlers = [ + handleCall (\s GetState -> reply (reverse s) s) + , handleCall (\s (cmd :: String) -> reply () ((Right cmd):s)) + , handleCast (\s (cmd :: String) -> continue ((Right cmd):s)) + ] + , infoHandlers = [ + handleInfo (\s (sig :: MyAlarmSignal) -> continue ((Left sig):s)) + ] + , unhandledMessagePolicy = Drop + , timeoutHandler = \_ _ -> stop $ ExitOther "timeout" + } :: ProcessDefinition [(Either MyAlarmSignal String)] + +mkOverflowHandlingServer :: (PrioritisedProcessDefinition Int -> + PrioritisedProcessDefinition Int) + -> Process ProcessId +mkOverflowHandlingServer modIt = + let p = procDef `prioritised` ([ + prioritiseCall_ (\GetState -> setPriority 99 :: Priority Int) + , prioritiseCast_ (\(_ :: String) -> setPriority 1) + ] :: [DispatchPriority Int] + ) :: PrioritisedProcessDefinition Int + in spawnLocal $ pserve () (initWait Infinity) (modIt p) + where + initWait :: Delay + -> InitHandler () Int + initWait d () = return $ InitOk 0 d + + procDef :: ProcessDefinition Int + procDef = + defaultProcess { + apiHandlers = [ + handleCall (\s GetState -> reply s s) + , handleCast (\s (_ :: String) -> continue $ s + 1) + ] + } :: ProcessDefinition Int + +launchStmServer :: CallHandler () String String -> Process StmServer +launchStmServer handler = do + (inQ, replyQ) <- liftIO $ do + cIn <- newTQueueIO + cOut <- newTQueueIO + return (cIn, cOut) + + let procDef = statelessProcess { + externHandlers = [ + handleCallExternal + (readTQueue inQ) + (writeTQueue replyQ) + handler + ] + , apiHandlers = [ + action (\() -> stop_ ExitNormal) + ] + } + + let p = procDef `prioritised` ([ + prioritiseCast_ (\() -> setPriority 99 :: Priority ()) + , prioritiseCast_ (\(_ :: String) -> setPriority 100) + ] :: [DispatchPriority ()] + ) :: PrioritisedProcessDefinition () + + pid <- spawnLocal $ pserve () (statelessInit Infinity) p + return $ StmServer pid inQ replyQ + +launchStmOverloadServer :: Process (ProcessId, ControlPort String) +launchStmOverloadServer = do + cc <- newControlChan :: Process (ControlChannel String) + let cp = channelControlPort cc + + let procDef = statelessProcess { + externHandlers = [ + handleControlChan_ cc (\(_ :: String) -> continue_) + ] + , apiHandlers = [ + handleCast (\s sp -> sendChan sp () >> continue s) + ] + } + + let p = procDef `prioritised` ([ + prioritiseCast_ (\() -> setPriority 99 :: Priority ()) + ] :: [DispatchPriority ()] + ) :: PrioritisedProcessDefinition () + + pid <- spawnLocal $ pserve () (statelessInit Infinity) p + return (pid, cp) + +data Foo = Foo deriving (Show) + +launchFilteredServer :: ProcessId -> Process (ProcessId, ControlPort (SendPort Int)) +launchFilteredServer us = do + cc <- newControlChan :: Process (ControlChannel (SendPort Int)) + let cp = channelControlPort cc + + let procDef = defaultProcess { + externHandlers = [ + handleControlChan cc (\s (p :: SendPort Int) -> sendChan p s >> continue s) + ] + , apiHandlers = [ + handleCast (\s sp -> sendChan sp () >> continue s) + , handleCall_ (\(s :: String) -> return s) + , handleCall_ (\(i :: Int) -> return i) + ] + , unhandledMessagePolicy = DeadLetter us + } :: ProcessDefinition Int + + let p = procDef `prioritised` ([ + prioritiseCast_ (\() -> setPriority 1 :: Priority ()) + , prioritiseCall_ (\(_ :: String) -> setPriority 100 :: Priority String) + ] :: [DispatchPriority Int] + ) :: PrioritisedProcessDefinition Int + + let rejectUnchecked = + rejectApi Foo :: Int -> P.Message String String -> Process (Filter Int) + + let p' = p { + filters = [ + store (+1) + , ensure (>0) -- a bit pointless, but we're just checking the API + + , check $ api_ (\(s :: String) -> return $ "checked-" `isInfixOf` s) rejectUnchecked + , check $ info (\_ (_ :: MonitorRef, _ :: ProcessId) -> return False) $ reject Foo + , refuse ((> 10) :: Int -> Bool) + ] + } + + pid <- spawnLocal $ pserve 0 (\c -> return $ InitOk c Infinity) p' + return (pid, cp) + +testStupidInfiniteLoop :: TestResult Bool -> Process () +testStupidInfiniteLoop result = do + let def = statelessProcess { + apiHandlers = [ + handleCast (\_ sp -> eval $ do q <- processQueue + m <- Gen.dequeue + Gen.lift $ sendChan sp (length q, m) + Gen.continue) + ] + , infoHandlers = [ + handleInfo (\_ (m :: String) -> eval $ do enqueue (wrapMessage m) + Gen.continue) + ] + } :: ProcessDefinition () + + let prio = def `prioritised` [] + pid <- spawnLocal $ pserve () (statelessInit Infinity) prio + + -- this message should create an infinite loop + send pid "fooboo" + + (sp, rp) <- newChan :: Process (SendPort (Int, Maybe Message), ReceivePort (Int, Maybe Message)) + + cast pid sp + (i, m) <- receiveChan rp + + cast pid sp + (i', m') <- receiveChan rp + + stash result $ (i == 1 && isJust m && i' == 0 && isNothing m') + +testFilteringBehavior :: TestResult Bool -> Process () +testFilteringBehavior result = do + us <- getSelfPid + (sp, rp) <- newChan + (pid, cp) <- launchFilteredServer us + mRef <- monitor pid + + sendControlMessage cp sp + + r <- receiveChan rp :: Process Int + when (r > 1) $ stash result False >> die "we're done..." + + Left _ <- safeCall pid "bad-input" :: Process (Either ExitReason String) + + send pid (mRef, us) -- server doesn't like this, dead letters it... + -- back to us + void $ receiveWait [ matchIf (\(m, p) -> m == mRef && p == us) return ] + + sendControlMessage cp sp + + r2 <- receiveChan rp :: Process Int + when (r2 < 3) $ stash result False >> die "we're done again..." + + -- server also doesn't like this, and sends it right back (via \DeadLetter us/) + send pid (25 :: Int) + + m <- receiveWait [ matchIf (== 25) return ] :: Process Int + stash result $ m == 25 + kill pid "done" + +testServerSwap :: TestResult Bool -> Process () +testServerSwap result = do + us <- getSelfPid + let def2 = statelessProcess { apiHandlers = [ handleCast (\s (i :: Int) -> send us (i, i+1) >> continue s) + , handleCall_ (\(i :: Int) -> return (i * 5)) + ] + , unhandledMessagePolicy = Drop -- otherwise `call` would fail + } + let def = statelessProcess + { apiHandlers = [ handleCall_ (\(m :: String) -> return m) ] + , infoHandlers = [ handleInfo (\s () -> become def2 s) ] + } `prioritised` [] + + pid <- spawnLocal $ pserve () (statelessInit Infinity) def + + m1 <- call pid "hello there" + let a1 = m1 == "hello there" + + send pid () --changeover + + m2 <- callTimeout pid "are you there?" (seconds 5) :: Process (Maybe String) + let a2 = isNothing m2 + + cast pid (45 :: Int) + res <- receiveWait [ matchIf (\(i :: Int) -> i == 45) (return . Left) + , match (\(_ :: Int, j :: Int) -> return $ Right j) ] + + let a3 = res == (Right 46) + + m4 <- call pid (20 :: Int) :: Process Int + let a4 = m4 == 100 + + stash result $ a1 && a2 && a3 && a4 + +testSafeExecutionContext :: TestResult Bool -> Process () +testSafeExecutionContext result = do + let t = (asTimeout $ seconds 5) + (sigSp, rp) <- newChan + (wp, lp) <- newChan + let def = statelessProcess + { apiHandlers = [ handleCall_ (\(m :: String) -> stranded rp wp Nothing >> return m) ] + , infoHandlers = [ handleInfo (\s (m :: String) -> stranded rp wp (Just m) >> continue s) ] + , exitHandlers = [ handleExit (\_ s (_ :: String) -> continue s) ] + } `prioritised` [] + + let spec = def { filters = [ + safe (\_ (_ :: String) -> True) + , apiSafe (\_ (_ :: String) (_ :: Maybe String) -> True) + ] + } + + pid <- spawnLocal $ pserve () (statelessInit Infinity) spec + send pid "hello" -- pid can't process this as it's stuck waiting on rp + + sleep $ seconds 3 + exit pid "ooops" -- now we force an exit signal once the receiveWait finishes + sendChan sigSp () -- and allow the receiveWait to complete + send pid "hi again" + + -- at this point, "hello" should still be in the backing queue/mailbox + sleep $ seconds 3 + + -- We should still be seeing "hello", since the 'safe' block saved us from + -- losing a message when we handled and swallowed the exit signal. + -- We should not see "hi again" until after "hello" has been processed + h <- receiveChanTimeout t lp + -- say $ "first response: " ++ (show h) + let a1 = h == (Just "hello") + + sleep $ seconds 3 + + -- now we should have "hi again" waiting in the mailbox... + sendChan sigSp () -- we must release the handler a second time... + h2 <- receiveChanTimeout t lp + -- say $ "second response: " ++ (show h2) + let a2 = h2 == (Just "hi again") + + void $ spawnLocal $ call pid "reply-please" >>= sendChan wp + + -- the call handler should be stuck waiting on rp + Nothing <- receiveChanTimeout (asTimeout $ seconds 2) lp + + -- now let's force an exit, then release the handler to see if it runs again... + exit pid "ooops2" + + sleep $ seconds 2 + sendChan sigSp () + + h3 <- receiveChanTimeout t lp +-- say $ "third response: " ++ (show h3) + let a3 = h3 == (Just "reply-please") + + stash result $ a1 && a2 && a3 + + where + + stranded :: ReceivePort () -> SendPort String -> Maybe String -> Process () + stranded gate chan str = do + -- say $ "stranded with " ++ (show str) + void $ receiveWait [ matchChan gate return ] + sleep $ seconds 1 + case str of + Nothing -> return () + Just s -> sendChan chan s + +testExternalTimedOverflowHandling :: TestResult Bool -> Process () +testExternalTimedOverflowHandling result = do + (pid, cp) <- launchStmOverloadServer -- default 10k mailbox drain limit + wrk <- spawnLocal $ mapM_ (sendControlMessage cp . show) ([1..500000] :: [Int]) + + sleep $ milliSeconds 250 -- give the worker time to start spamming the server... + + (sp, rp) <- newChan + cast pid sp -- tell the server we're expecting a reply + + -- it might take "a while" for us to get through the first 10k messages + -- from our chatty friend wrk, before we finally get our control message seen + -- by the reader/listener loop, and in fact timing wise we don't even know when + -- our message will arrive, since we're racing with wrk to communicate with + -- the server. It's important therefore to give sufficient time for the right + -- conditions to occur so that our message is finally received and processed, + -- yet we don't want to lock up the build for 10-20 mins either. This value + -- of 30 seconds seems like a reasonable compromise. + answer <- receiveChanTimeout (asTimeout $ seconds 30) rp + + stash result $ answer == Just () + kill wrk "done" + kill pid "done" + +testExternalCall :: TestResult Bool -> Process () +testExternalCall result = do + let txt = "hello stm-call foo" + srv <- launchStmServer (\st (msg :: String) -> reply msg st) + echoStm srv txt >>= stash result . (== Right txt) + killProc srv "done" + +testTimedOverflowHandling :: TestResult Bool -> Process () +testTimedOverflowHandling result = do + pid <- mkOverflowHandlingServer (\s -> s { recvTimeout = RecvTimer $ within 3 Seconds }) + wrk <- spawnLocal $ mapM_ (cast pid . show) ([1..500000] :: [Int]) + + sleep $ seconds 1 -- give the worker time to start spamming us... + cast pid "abc" -- just getting in line here... + + st <- call pid GetState :: Process Int + -- the result of GetState is a list of messages in reverse insertion order + stash result $ st > 0 + kill wrk "done" + kill pid "done" + +testOverflowHandling :: TestResult Bool -> Process () +testOverflowHandling result = do + pid <- mkOverflowHandlingServer (\s -> s { recvTimeout = RecvMaxBacklog 100 }) + wrk <- spawnLocal $ mapM_ (cast pid . show) ([1..50000] :: [Int]) + + sleep $ seconds 1 + cast pid "abc" -- just getting in line here... + + st <- call pid GetState :: Process Int + -- the result of GetState is a list of messages in reverse insertion order + stash result $ st > 0 + kill wrk "done" + kill pid "done" + +testInfoPrioritisation :: TestResult Bool -> Process () +testInfoPrioritisation result = do + pid <- mkPrioritisedServer + -- the server (pid) is configured to wait for () during its init + -- so we can fill up its mailbox with String messages, and verify + -- that the alarm signal (which is prioritised *above* these) + -- actually gets processed first despite the delivery order + cast pid "hello" + cast pid "prioritised" + cast pid "world" + -- note that these have to be a "bare send" + send pid MyAlarmSignal + -- tell the server it can move out of init and start processing messages + send pid () + st <- call pid GetState :: Process [Either MyAlarmSignal String] + -- the result of GetState is a list of messages in reverse insertion order + case head st of + Left MyAlarmSignal -> stash result True + _ -> stash result False + +testUserTimerHandling :: TestResult Bool -> Process () +testUserTimerHandling result = do + us <- getSelfPid + let p = (procDef us) `prioritised` ([ + prioritiseInfo_ (\MyAlarmSignal -> setPriority 100) + ] :: [DispatchPriority ()] + ) :: PrioritisedProcessDefinition () + pid <- spawnLocal $ pserve () (statelessInit Infinity) p + cast pid () + expect >>= stash result . (== MyAlarmSignal) + kill pid "goodbye..." + + where + + procDef :: ProcessId -> ProcessDefinition () + procDef us = + statelessProcess { + apiHandlers = [ + handleCast (\s () -> evalAfter (seconds 5) MyAlarmSignal s) + ] + , infoHandlers = [ + handleInfo (\s (sig :: MyAlarmSignal) -> send us sig >> continue s) + ] + , unhandledMessagePolicy = Drop + } :: ProcessDefinition () + + +testCallPrioritisation :: TestResult Bool -> Process () +testCallPrioritisation result = do + pid <- mkPrioritisedServer + asyncRefs <- (mapM (callAsync pid) + ["first", "the longest", "commands", "we do prioritise"]) + :: Process [Async ()] + -- NB: This sleep is really important - the `init' function is waiting + -- (selectively) on the () signal to go, and if it receives this *before* + -- the async worker has had a chance to deliver the longest string message, + -- our test will fail. Such races are /normal/ given that the async worker + -- runs in another process and delivery order between multiple processes + -- is undefined (and in practise, partially depenendent on the scheduler) + sleep $ seconds 1 + send pid () + _ <- mapM wait asyncRefs :: Process [AsyncResult ()] + st <- call pid GetState :: Process [Either MyAlarmSignal String] + let ms = rights st + stash result $ ms == ["we do prioritise", "the longest", "commands", "first"] + +tests :: NT.Transport -> IO [Test] +tests transport = do + localNode <- newLocalNode transport initRemoteTable + return [ + testGroup "basic server functionality matches un-prioritised processes" [ + testCase "basic call with explicit server reply" + (delayedAssertion + "expected a response from the server" + localNode (Just "foo") (testBasicCall $ wrap server)) + , testCase "basic call with implicit server reply" + (delayedAssertion + "expected n * 2 back from the server" + localNode (Just 4) (testBasicCall_ $ wrap server)) + , testCase "basic deferred call handling" + (delayedAssertion "expected a response sent via replyTo" + localNode (AsyncDone "Hello There") testDeferredCallResponse) + , testCase "basic cast with manual send and explicit server continue" + (delayedAssertion + "expected pong back from the server" + localNode (Just "pong") (testBasicCast $ wrap server)) + , testCase "cast and explicit server timeout" + (delayedAssertion + "expected the server to stop after the timeout" + localNode (Just $ ExitOther "timeout") (testControlledTimeout $ wrap server)) + , testCase "unhandled input when policy = Terminate" + (delayedAssertion + "expected the server to stop upon receiving unhandled input" + localNode (Just $ ExitOther "UnhandledInput") + (testTerminatePolicy $ wrap server)) + , testCase "unhandled input when policy = Drop" + (delayedAssertion + "expected the server to ignore unhandled input and exit normally" + localNode Nothing (testDropPolicy $ wrap (mkServer Drop))) + , testCase "unhandled input when policy = DeadLetter" + (delayedAssertion + "expected the server to forward unhandled messages" + localNode (Just ("UNSOLICITED_MAIL", 500 :: Int)) + (testDeadLetterPolicy $ \p -> mkServer (DeadLetter p))) + , testCase "incoming messages are ignored whilst hibernating" + (delayedAssertion + "expected the server to remain in hibernation" + localNode True (testHibernation $ wrap server)) + , testCase "long running call cancellation" + (delayedAssertion "expected to get AsyncCancelled" + localNode True (testKillMidCall $ wrap server)) + , testCase "server rejects call" + (delayedAssertion "expected server to send CallRejected" + localNode (ExitOther "invalid-call") (testServerRejectsMessage $ wrap server)) + , testCase "simple exit handling" + (delayedAssertion "expected handler to catch exception and continue" + localNode Nothing (testSimpleErrorHandling $ explodingServer)) + , testCase "alternative exit handlers" + (delayedAssertion "expected handler to catch exception and continue" + localNode Nothing (testAlternativeErrorHandling $ explodingServer)) + ] + , testGroup "Prioritised Mailbox Handling" [ + testCase "Info Message Prioritisation" + (delayedAssertion "expected the info handler to be prioritised" + localNode True testInfoPrioritisation) + , testCase "Call Message Prioritisation" + (delayedAssertion "expected the longest strings to be prioritised" + localNode True testCallPrioritisation) + , testCase "Size-Based Mailbox Overload Management" + (delayedAssertion "expected the server loop to stop reading the mailbox" + localNode True testOverflowHandling) + , testCase "Timeout-Based Mailbox Overload Management" + (delayedAssertion "expected the server loop to stop reading the mailbox" + localNode True testTimedOverflowHandling) + ] + , testGroup "Advanced Server Interactions" [ + testCase "using callSTM to manage non-CH interactions" + (delayedAssertion + "expected the server to reply back via the TQueue" + localNode True testExternalCall) + , testCase "Timeout-Based Overload Management with Control Channels" + (delayedAssertion "expected the server loop to reply" + localNode True testExternalTimedOverflowHandling) + , testCase "Complex pre/before filters" + (delayedAssertion "expected verifiable filter actions" + localNode True testFilteringBehavior) + , testCase "Firing internal timeouts" + (delayedAssertion "expected our info handler to run after the timeout" + localNode True testUserTimerHandling) + , testCase "Creating 'Safe' Handlers" + (delayedAssertion "expected our handler to run on the old message" + localNode True testSafeExecutionContext) + , testCase "Swapping ProcessDefinitions at runtime" + (delayedAssertion "expected our handler to exist in the new handler list" + localNode True testServerSwap) + , testCase "Accessing the internal process implementation" + (delayedAssertion "it should allow us to modify the internal q" + localNode True testStupidInfiniteLoop) + ] + ] + +main :: IO () +main = testMain $ tests diff --git a/packages/distributed-process-client-server/tests/TestUtils.hs b/packages/distributed-process-client-server/tests/TestUtils.hs new file mode 100644 index 00000000..a6ac5116 --- /dev/null +++ b/packages/distributed-process-client-server/tests/TestUtils.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} + +module TestUtils + ( testMain + , mkNode + , waitForExit + ) where + +import Control.Concurrent.MVar + ( MVar + , takeMVar + ) + +import Control.Distributed.Process +import Control.Distributed.Process.Node +import Control.Distributed.Process.Extras +import Control.Distributed.Process.Extras.Time +import Control.Distributed.Process.Extras.Timer +import Test.Framework (Test, defaultMain) + +import Network.Transport.TCP +import qualified Network.Transport as NT + +waitForExit :: MVar ExitReason + -> Process (Maybe ExitReason) +waitForExit exitReason = do + -- we *might* end up blocked here, so ensure the test doesn't jam up! + self <- getSelfPid + tref <- killAfter (within 10 Seconds) self "testcast timed out" + tr <- liftIO $ takeMVar exitReason + cancelTimer tref + case tr of + ExitNormal -> return Nothing + other -> return $ Just other + +mkNode :: String -> IO LocalNode +mkNode port = do + Right (transport1, _) <- createTransportExposeInternals (defaultTCPAddr "127.0.0.1" port) defaultTCPParameters + newLocalNode transport1 initRemoteTable + +-- | Given a @builder@ function, make and run a test suite on a single transport +testMain :: (NT.Transport -> IO [Test]) -> IO () +testMain builder = do + Right (transport, _) <- createTransportExposeInternals (defaultTCPAddr "127.0.0.1" "0") defaultTCPParameters + testData <- builder transport + defaultMain testData diff --git a/packages/distributed-process-execution/ChangeLog b/packages/distributed-process-execution/ChangeLog new file mode 100644 index 00000000..02fcd76e --- /dev/null +++ b/packages/distributed-process-execution/ChangeLog @@ -0,0 +1,14 @@ +2015-06-15 Facundo Domínguez 0.1.2 + +* Add compatibility with ghc-7.10. +* Fix dependency bounds. +* Reuse test modules from distributed-proces-tests. + +# HEAD + +* Added initial GenServer module +* Added Timer Module +* Moved time functions into Time.hs +* Added Async API +* Added GenProcess API (subsumes lower level GenServer API) + diff --git a/packages/distributed-process-execution/LICENCE b/packages/distributed-process-execution/LICENCE new file mode 100644 index 00000000..f7a8c56f --- /dev/null +++ b/packages/distributed-process-execution/LICENCE @@ -0,0 +1,30 @@ +Copyright Tim Watson, 2012-2013. + +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. diff --git a/packages/distributed-process-execution/distributed-process-execution.cabal b/packages/distributed-process-execution/distributed-process-execution.cabal new file mode 100644 index 00000000..259493e1 --- /dev/null +++ b/packages/distributed-process-execution/distributed-process-execution.cabal @@ -0,0 +1,145 @@ +cabal-version: 3.0 +name: distributed-process-execution +version: 0.1.2.2 +build-type: Simple +license: BSD-3-Clause +license-file: LICENCE +stability: experimental +Copyright: Tim Watson 2012 - 2013 +Author: Tim Watson +maintainer: The Distributed Haskell team +Homepage: http://github.com/haskell-distributed/distributed-process-execution +Bug-Reports: http://github.com/haskell-distributed/distributed-process-execution/issues +synopsis: Execution Framework for The Cloud Haskell Application Platform +description: + The Execution Framework provides tools for load regulation, workload shedding and remote hand-off. + The currently implementation provides only a subset of the plumbing required, comprising tools + for event management, mailbox buffering and message routing. +category: Control +tested-with: GHC==8.10.7 GHC==9.0.2 GHC==9.2.8 GHC==9.4.5 GHC==9.6.4 GHC==9.8.2 GHC==9.10.1 +extra-source-files: ChangeLog + +source-repository head + type: git + location: https://github.com/haskell-distributed/distributed-process-execution + +common warnings + ghc-options: -Wall + -Wcompat + -Widentities + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wredundant-constraints + -fhide-source-paths + -Wpartial-fields + +library + import: warnings + build-depends: + base >= 4.14 && < 5, + data-accessor >= 0.2.2.3, + distributed-process >= 0.6.6 && < 0.8, + distributed-process-extras >= 0.3.1 && < 0.4, + distributed-process-supervisor >= 0.2.0 && < 0.3, + distributed-process-client-server >= 0.2.0 && < 0.3, + binary >= 0.8 && < 0.9, + deepseq >= 1.4 && < 1.6, + mtl, + containers >= 0.6 && < 0.8, + hashable >= 1.2.0.5 && < 1.6, + unordered-containers >= 0.2.3.0 && < 0.3, + fingertree < 0.2, + stm >= 2.4 && < 2.6, + time, + transformers + hs-source-dirs: src + exposed-modules: + Control.Distributed.Process.Execution, + Control.Distributed.Process.Execution.EventManager, + Control.Distributed.Process.Execution.Exchange, + Control.Distributed.Process.Execution.Mailbox + other-modules: + Control.Distributed.Process.Execution.Exchange.Broadcast, + Control.Distributed.Process.Execution.Exchange.Internal, + Control.Distributed.Process.Execution.Exchange.Router + + +test-suite ExchangeTests + import: warnings + type: exitcode-stdio-1.0 +-- x-uses-tf: true + build-depends: + base >= 4.14 && < 5, + ansi-terminal >= 0.5 && < 0.7, + containers, + hashable, + unordered-containers >= 0.2.3.0 && < 0.3, + distributed-process, + distributed-process-execution, + distributed-process-extras, + distributed-process-systest >= 0.1.1 && < 0.4, + distributed-static, + bytestring, + data-accessor, + fingertree < 0.2, + network-transport >= 0.4 && < 0.6, + deepseq, + mtl, + network-transport-tcp >= 0.4 && < 0.9, + binary >= 0.8 && < 0.9, + network >= 2.3 && < 3.3, + HUnit >= 1.2 && < 2, + stm, + time, + test-framework >= 0.6 && < 0.9, + test-framework-hunit, + QuickCheck >= 2.4, + test-framework-quickcheck2, + transformers, + rematch >= 0.2.0.0, + ghc-prim + hs-source-dirs: + tests + ghc-options: -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind -eventlog + main-is: TestExchange.hs + + +test-suite MailboxTests + import: warnings + type: exitcode-stdio-1.0 +-- x-uses-tf: true + build-depends: + base >= 4.14 && < 5, + ansi-terminal >= 0.5 && < 0.7, + containers, + hashable, + unordered-containers >= 0.2.3.0 && < 0.3, + distributed-process, + distributed-process-execution, + distributed-process-extras, + distributed-process-systest >= 0.1.1 && < 0.4, + distributed-static, + bytestring, + data-accessor, + fingertree < 0.2, + network-transport >= 0.4 && < 0.6, + deepseq, + mtl, + network-transport-tcp >= 0.4 && < 0.9, + binary >= 0.8 && < 0.9, + network >= 2.3 && < 3.3, + HUnit >= 1.2 && < 2, + stm, + time, + test-framework >= 0.6 && < 0.9, + test-framework-hunit, + QuickCheck >= 2.4, + test-framework-quickcheck2, + transformers, + rematch >= 0.2.0.0, + ghc-prim + hs-source-dirs: + tests + ghc-options: -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind -eventlog + main-is: TestMailbox.hs + other-modules: MailboxTestFilters diff --git a/packages/distributed-process-execution/src/Control/Distributed/Process/Execution.hs b/packages/distributed-process-execution/src/Control/Distributed/Process/Execution.hs new file mode 100644 index 00000000..d7aac6c5 --- /dev/null +++ b/packages/distributed-process-execution/src/Control/Distributed/Process/Execution.hs @@ -0,0 +1,44 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Control.Distributed.Process.Execution +-- Copyright : (c) Tim Watson 2013 - 2014 +-- License : BSD3 (see the file LICENSE) +-- +-- Maintainer : Tim Watson +-- Stability : experimental +-- Portability : non-portable (requires concurrency) +-- +-- [Inter-Process Traffic Management] +-- +-- The /Execution Framework/ provides tools for load regulation, workload +-- shedding and remote hand-off. The currently implementation provides only +-- a subset of the plumbing required, comprising tools for event management, +-- mailbox buffering and message routing. +-- +----------------------------------------------------------------------------- + +module Control.Distributed.Process.Execution + ( -- * Mailbox Buffering + module Control.Distributed.Process.Execution.Mailbox + -- * Message Exchanges + , module Control.Distributed.Process.Execution.Exchange + ) where + +import Control.Distributed.Process.Execution.Exchange hiding (startSupervised) +import Control.Distributed.Process.Execution.Mailbox hiding (startSupervised, post) + +{- + +Load regulation requires that we apply limits to various parts of the system. +The manner in which they're applied may vary, but the mechanisms are limited +to: + +1. rejecting the activity/request +2. accepting the activity immediately +3. blocking some or all requestors +4. blocking some (or all) activities +5. terminiating some (or all) activities + +-} + + diff --git a/packages/distributed-process-execution/src/Control/Distributed/Process/Execution/EventManager.hs b/packages/distributed-process-execution/src/Control/Distributed/Process/Execution/EventManager.hs new file mode 100644 index 00000000..62b83019 --- /dev/null +++ b/packages/distributed-process-execution/src/Control/Distributed/Process/Execution/EventManager.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ImpredicativeTypes #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Distributed.Process.Execution.EventManager +-- Copyright : (c) Well-Typed / Tim Watson +-- License : BSD3 (see the file LICENSE) +-- +-- Maintainer : Tim Watson +-- Stability : experimental +-- Portability : non-portable (requires concurrency) +-- +-- [Overview] +-- +-- The /EventManager/ is a parallel/concurrent event handling tool, built on +-- top of the /Exchange API/. Arbitrary events are published to the event +-- manager using 'notify', and are broadcast simulataneously to a set of +-- registered /event handlers/. +-- +-- [Defining and Registering Event Handlers] +-- +-- Event handlers are defined as @Serializable m => s -> m -> Process s@, +-- i.e., an expression taking an initial state, an arbitrary @Serializable@ +-- event/message and performing an action in the @Process@ monad that evaluates +-- to a new state. +-- +-- See "Control.Distributed.Process.Execution.Exchange". +-- +----------------------------------------------------------------------------- + +module Control.Distributed.Process.Execution.EventManager + ( EventManager + , start + , startSupervised + , startSupervisedRef + , notify + , addHandler + , addMessageHandler + ) where + +import Control.Distributed.Process hiding (Message, link) +import qualified Control.Distributed.Process as P (Message) +import Control.Distributed.Process.Execution.Exchange + ( Exchange + , Message(..) + , post + , broadcastExchange + , broadcastExchangeT + , broadcastClient + ) +import qualified Control.Distributed.Process.Execution.Exchange as Exchange + ( startSupervised + ) +import Control.Distributed.Process.Extras.Internal.Primitives +import Control.Distributed.Process.Extras.Internal.Unsafe + ( InputStream + , matchInputStream + ) +import Control.Distributed.Process.Supervisor (SupervisorPid) +import Control.Distributed.Process.Serializable hiding (SerializableDict) +import Data.Binary +import Data.Typeable (Typeable) +import GHC.Generics + +{- notes + +Event manager is implemented over a simple BroadcastExchange. We eschew the +complexities of identifying handlers and allowing them to be removed/deleted +or monitored, since we avoid running them in the exchange process. Instead, +each handler runs as an independent process, leaving handler management up +to the user and allowing all the usual process managemnet techniques (e.g., +registration, supervision, etc) to be utilised instead. + +-} + +-- | Opaque handle to an Event Manager. +-- +newtype EventManager = EventManager { ex :: Exchange } + deriving (Typeable, Generic) +instance Binary EventManager where + +instance Resolvable EventManager where + resolve = resolve . ex + +-- | Start a new /Event Manager/ process and return an opaque handle +-- to it. +start :: Process EventManager +start = broadcastExchange >>= return . EventManager + +startSupervised :: SupervisorPid -> Process EventManager +startSupervised sPid = do + ex <- broadcastExchangeT >>= \t -> Exchange.startSupervised t sPid + return $ EventManager ex + +startSupervisedRef :: SupervisorPid -> Process (ProcessId, P.Message) +startSupervisedRef sPid = do + ex <- startSupervised sPid + Just pid <- resolve ex + return (pid, unsafeWrapMessage ex) + +-- | Broadcast an event to all registered handlers. +notify :: Serializable a => EventManager -> a -> Process () +notify em msg = post (ex em) msg + +-- | Add a new event handler. The handler runs in its own process, +-- which is spawned locally on behalf of the caller. +addHandler :: forall s a. Serializable a + => EventManager + -> (s -> a -> Process s) + -> Process s + -> Process ProcessId +addHandler m h s = + spawnLocal $ newHandler (ex m) (\s' m' -> handleMessage m' (h s')) s + +-- | As 'addHandler', but operates over a raw @Control.Distributed.Process.Message@. +addMessageHandler :: forall s. + EventManager + -> (s -> P.Message -> Process (Maybe s)) + -> Process s + -> Process ProcessId +addMessageHandler m h s = spawnLocal $ newHandler (ex m) h s + +newHandler :: forall s . + Exchange + -> (s -> P.Message -> Process (Maybe s)) + -> Process s + -> Process () +newHandler ex handler initState = do + linkTo ex + is <- broadcastClient ex + listen is handler =<< initState + +listen :: forall s . InputStream Message + -> (s -> P.Message -> Process (Maybe s)) + -> s + -> Process () +listen inStream handler state = do + receiveWait [ matchInputStream inStream ] >>= handleEvent inStream handler state + where + handleEvent is h s p = do + r <- h s (payload p) + let s2 = case r of + Nothing -> s + Just s' -> s' + listen is h s2 + diff --git a/packages/distributed-process-execution/src/Control/Distributed/Process/Execution/Exchange.hs b/packages/distributed-process-execution/src/Control/Distributed/Process/Execution/Exchange.hs new file mode 100644 index 00000000..fce4d756 --- /dev/null +++ b/packages/distributed-process-execution/src/Control/Distributed/Process/Execution/Exchange.hs @@ -0,0 +1,149 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Control.Distributed.Process.Execution.Exchange +-- Copyright : (c) Tim Watson 2012 - 2014 +-- License : BSD3 (see the file LICENSE) +-- +-- Maintainer : Tim Watson +-- Stability : experimental +-- Portability : non-portable (requires concurrency) +-- +-- [Message Exchanges] +-- +-- The concept of a /message exchange/ is borrowed from the world of +-- messaging and enterprise integration. The /exchange/ acts like a kind of +-- mailbox, accepting inputs from /producers/ and forwarding these messages +-- to one or more /consumers/, depending on the implementation's semantics. +-- +-- This module provides some basic types of message exchange and exposes an API +-- for defining your own custom /exchange types/. +-- +-- [Broadcast Exchanges] +-- +-- The broadcast exchange type, started via 'broadcastExchange', forward their +-- inputs to all registered consumers (as the name suggests). This exchange type +-- is highly optimised for local (intra-node) traffic and provides two different +-- kinds of client binding, one which causes messages to be delivered directly +-- to the client's mailbox (viz 'bindToBroadcaster'), the other providing a +-- separate stream of messages that can be obtained using the @expect@ and +-- @receiveX@ family of messaging primitives (and thus composed with other forms +-- of input selection, such as typed channels and selective reads on the process +-- mailbox). +-- +-- /Important:/ When a @ProcessId@ is registered via 'bindToBroadcaster', only +-- the payload of the 'Message' (i.e., the underlying @Serializable@ datum) is +-- forwarded to the consumer, /not/ the whole 'Message' itself. +-- +-- [Router Exchanges] +-- +-- The /router/ API provides a means to selectively route messages to one or +-- more clients, depending on the content of the 'Message'. Two modes of binding +-- (and client selection) are provided out of the box, one of which matches the +-- message 'key', the second of which matches on a name and value from the +-- 'headers'. Alternative mechanisms for content based routing can be derived +-- by modifying the 'BindingSelector' expression passed to 'router' +-- +-- See 'messageKeyRouter' and 'headerContentRouter' for the built-in routing +-- exchanges, and 'router' for the extensible routing API. +-- +-- [Custom Exchange Types] +-- +-- Both the /broadcast/ and /router/ exchanges are implemented as custom +-- /exchange types/. The mechanism for defining custom exchange behaviours +-- such as these is very simple. Raw exchanges are started by evaluating +-- 'startExchange' with a specific 'ExchangeType' record. This type is +-- parameterised by the internal /state/ it holds, and defines two API callbacks +-- in its 'configureEx' and 'routeEx' fields. The former is evaluated whenever a +-- client process evaluates 'configureExchange', the latter whenever a client +-- evaluates 'post' or 'postMessage'. The 'configureEx' callback takes a raw +-- @Message@ (from "Control.Distributed.Process") and is responsible for +-- decoding the message and updating its own state (if required). It is via +-- this callback that custom exchange types can receive information about +-- clients and handle it in their own way. The 'routeEx' callback is evaluated +-- with the exchange type's own internal state and the 'Message' originally +-- sent to the exchange process (via 'post') and is responsible for delivering +-- the message to its clients in whatever way makes sense for that exchange +-- type. +-- +----------------------------------------------------------------------------- + +module Control.Distributed.Process.Execution.Exchange + ( -- * Fundamental API + Exchange() + , Message(..) + -- * Starting/Running an Exchange + , startExchange + , startSupervised + , startSupervisedRef + , runExchange + -- * Client Facing API + , post + , postMessage + , configureExchange + , createMessage + -- * Broadcast Exchange + , broadcastExchange + , broadcastExchangeT + , broadcastClient + , bindToBroadcaster + , BroadcastExchange + -- * Routing (Content Based) + , HeaderName + , Binding(..) + , Bindable + , BindingSelector + , RelayType(..) + -- * Starting a Router + , router + , supervisedRouter + -- * Routing (Publishing) API + , route + , routeMessage + -- * Routing via message/binding keys + , messageKeyRouter + , bindKey + -- * Routing via message headers + , headerContentRouter + , bindHeader + -- * Defining Custom Exchange Types + , ExchangeType(..) + , applyHandlers + ) where + +import Control.Distributed.Process.Execution.Exchange.Broadcast + ( broadcastExchange + , broadcastExchangeT + , broadcastClient + , bindToBroadcaster + , BroadcastExchange + ) +import Control.Distributed.Process.Execution.Exchange.Internal + ( Exchange() + , Message(..) + , ExchangeType(..) + , startExchange + , startSupervised + , startSupervisedRef + , runExchange + , post + , postMessage + , configureExchange + , createMessage + , applyHandlers + ) +import Control.Distributed.Process.Execution.Exchange.Router + ( HeaderName + , Binding(..) + , Bindable + , BindingSelector + , RelayType(..) + , router + , supervisedRouter + , route + , routeMessage + , messageKeyRouter + , bindKey + , headerContentRouter + , bindHeader + ) + diff --git a/packages/distributed-process-execution/src/Control/Distributed/Process/Execution/Exchange/Broadcast.hs b/packages/distributed-process-execution/src/Control/Distributed/Process/Execution/Exchange/Broadcast.hs new file mode 100644 index 00000000..e5b6cd35 --- /dev/null +++ b/packages/distributed-process-execution/src/Control/Distributed/Process/Execution/Exchange/Broadcast.hs @@ -0,0 +1,338 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | An exchange type that broadcasts all incomings 'Post' messages. +module Control.Distributed.Process.Execution.Exchange.Broadcast + ( + broadcastExchange + , broadcastExchangeT + , broadcastClient + , bindToBroadcaster + , BroadcastExchange + ) where + +import Control.Concurrent.STM (STM, atomically) +import Control.Concurrent.STM.TChan + ( TChan + , newBroadcastTChanIO + , dupTChan + , readTChan + , writeTChan + ) +import Control.DeepSeq (NFData) +import Control.Distributed.Process + ( Process + , MonitorRef + , ProcessMonitorNotification(..) + , ProcessId + , SendPort + , processNodeId + , getSelfPid + , getSelfNode + , liftIO + , newChan + , sendChan + , unsafeSend + , unsafeSendChan + , receiveWait + , match + , matchIf + , die + , handleMessage + , Match + ) +import qualified Control.Distributed.Process as P +import Control.Distributed.Process.Serializable() +import Control.Distributed.Process.Execution.Exchange.Internal + ( startExchange + , configureExchange + , Message(..) + , Exchange(..) + , ExchangeType(..) + , applyHandlers + ) +import Control.Distributed.Process.Extras.Internal.Types + ( Channel + , ServerDisconnected(..) + ) +import Control.Distributed.Process.Extras.Internal.Unsafe -- see [note: pcopy] + ( PCopy + , pCopy + , pUnwrap + , matchChanP + , InputStream(Null) + , newInputStream + ) +import Control.Monad (forM_, void) +import Data.Accessor + ( Accessor + , accessor + , (^:) + ) +import Data.Binary +import qualified Data.Foldable as Foldable (toList) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Typeable (Typeable) +import GHC.Generics + +-- newtype RoutingTable r = +-- RoutingTable { routes :: (Map String (Map ProcessId r)) } + +-- [note: BindSTM, BindPort and safety] +-- We keep these two /bind types/ separate, since only one of them +-- is truly serializable. The risk of unifying them is that at some +-- later time a maintainer might not realise that BindSTM cannot be +-- sent over the wire due to our use of PCopy. +-- + +data BindPort = BindPort { portClient :: !ProcessId + , portSend :: !(SendPort Message) + } deriving (Typeable, Generic) +instance Binary BindPort where +instance NFData BindPort where + +data BindSTM = + BindSTM { stmClient :: !ProcessId + , stmSend :: !(SendPort (PCopy (InputStream Message))) + } deriving (Typeable) +{- | forall r. (Routable r) => + BindR { client :: !ProcessId + , key :: !String + , chanC :: !r + } + deriving (Typeable, Generic) +-} + +data OutputStream = + WriteChan (SendPort Message) + | WriteSTM (Message -> STM ()) +-- | WriteP ProcessId + | NoWrite + deriving (Typeable) + +data Binding = Binding { outputStream :: !OutputStream + , inputStream :: !(InputStream Message) + } + | PidBinding !ProcessId + deriving (Typeable) + +data BindOk = BindOk + deriving (Typeable, Generic) +instance Binary BindOk where +instance NFData BindOk where + +data BindFail = BindFail !String + deriving (Typeable, Generic) +instance Binary BindFail where +instance NFData BindFail where + +data BindPlease = BindPlease + deriving (Typeable, Generic) +instance Binary BindPlease where +instance NFData BindPlease where + +type BroadcastClients = Map ProcessId Binding +data BroadcastEx = + BroadcastEx { _routingTable :: !BroadcastClients + , channel :: !(TChan Message) + } + +type BroadcastExchange = ExchangeType BroadcastEx + +-------------------------------------------------------------------------------- +-- Starting/Running the Exchange -- +-------------------------------------------------------------------------------- + +-- | Start a new /broadcast exchange/ and return a handle to the exchange. +broadcastExchange :: Process Exchange +broadcastExchange = broadcastExchangeT >>= startExchange + +-- | The 'ExchangeType' of a broadcast exchange. Can be combined with the +-- @startSupervisedRef@ and @startSupervised@ APIs. +-- +broadcastExchangeT :: Process BroadcastExchange +broadcastExchangeT = do + ch <- liftIO newBroadcastTChanIO + return $ ExchangeType { name = "BroadcastExchange" + , state = BroadcastEx Map.empty ch + , configureEx = apiConfigure + , routeEx = apiRoute + } + +-------------------------------------------------------------------------------- +-- Client Facing API -- +-------------------------------------------------------------------------------- + +-- | Create a binding to the given /broadcast exchange/ for the calling process +-- and return an 'InputStream' that can be used in the @expect@ and +-- @receiveWait@ family of messaging primitives. This form of client interaction +-- helps avoid cluttering the caller's mailbox with 'Message' data, since the +-- 'InputChannel' provides a separate input stream (in a similar fashion to +-- a typed channel). +-- Example: +-- +-- > is <- broadcastClient ex +-- > msg <- receiveWait [ matchInputStream is ] +-- > handleMessage (payload msg) +-- +broadcastClient :: Exchange -> Process (InputStream Message) +broadcastClient ex@Exchange{..} = do + myNode <- getSelfNode + us <- getSelfPid + if processNodeId pid == myNode -- see [note: pcopy] + then do (sp, rp) <- newChan + configureExchange ex $ pCopy (BindSTM us sp) + mRef <- P.monitor pid + P.finally (receiveWait [ matchChanP rp + , handleServerFailure mRef ]) + (P.unmonitor mRef) + else do (sp, rp) <- newChan :: Process (Channel Message) + configureExchange ex $ BindPort us sp + mRef <- P.monitor pid + P.finally (receiveWait [ + match (\(_ :: BindOk) -> return $ newInputStream $ Left rp) + , match (\(f :: BindFail) -> die f) + , handleServerFailure mRef + ]) + (P.unmonitor mRef) + +-- | Bind the calling process to the given /broadcast exchange/. For each +-- 'Message' the exchange receives, /only the payload will be sent/ +-- to the calling process' mailbox. +-- +-- Example: +-- +-- (producer) +-- > post ex "Hello" +-- +-- (consumer) +-- > bindToBroadcaster ex +-- > expect >>= liftIO . putStrLn +-- +bindToBroadcaster :: Exchange -> Process () +bindToBroadcaster ex@Exchange{..} = do + us <- getSelfPid + configureExchange ex $ (BindPlease, us) + +-------------------------------------------------------------------------------- +-- Exchage Definition/State & API Handlers -- +-------------------------------------------------------------------------------- + +apiRoute :: BroadcastEx -> Message -> Process BroadcastEx +apiRoute ex@BroadcastEx{..} msg = do + liftIO $ atomically $ writeTChan channel msg + forM_ (Foldable.toList _routingTable) $ routeToClient msg + return ex + where + routeToClient m (PidBinding p) = P.forward (payload m) p + routeToClient m b@(Binding _ _) = writeToStream (outputStream b) m + +-- TODO: implement unbind!!? + +apiConfigure :: BroadcastEx -> P.Message -> Process BroadcastEx +apiConfigure ex msg = do + -- for unsafe / non-serializable message passing hacks, see [note: pcopy] + applyHandlers ex msg $ [ \m -> handleMessage m (handleBindPort ex) + , \m -> handleBindSTM ex m + , \m -> handleMessage m (handleBindPlease ex) + , \m -> handleMessage m (handleMonitorSignal ex) + , (const $ return $ Just ex) + ] + where + handleBindPlease ex' (BindPlease, p) = do + case lookupBinding ex' p of + Nothing -> return $ (routingTable ^: Map.insert p (PidBinding p)) ex' + Just _ -> return ex' + + handleMonitorSignal bx (ProcessMonitorNotification _ p _) = + return $ (routingTable ^: Map.delete p) bx + + handleBindSTM ex'@BroadcastEx{..} msg' = do + bind' <- pUnwrap msg' :: Process (Maybe BindSTM) -- see [note: pcopy] + case bind' of + Nothing -> return Nothing + Just s -> do + let binding = lookupBinding ex' (stmClient s) + case binding of + Nothing -> createBinding ex' s >>= \ex'' -> handleBindSTM ex'' msg' + Just b -> sendBinding (stmSend s) b >> return (Just ex') + + createBinding bEx'@BroadcastEx{..} BindSTM{..} = do + void $ P.monitor stmClient + nch <- liftIO $ atomically $ dupTChan channel + let istr = newInputStream $ Right (readTChan nch) + let ostr = NoWrite -- we write to our own channel, not the broadcast + let bnd = Binding ostr istr + return $ (routingTable ^: Map.insert stmClient bnd) bEx' + + sendBinding sp' bs = unsafeSendChan sp' $ pCopy (inputStream bs) + + handleBindPort :: BroadcastEx -> BindPort -> Process BroadcastEx + handleBindPort x@BroadcastEx{..} BindPort{..} = do + let binding = lookupBinding x portClient + case binding of + Just _ -> unsafeSend portClient (BindFail "DuplicateBinding") >> return x + Nothing -> do + let istr = Null + let ostr = WriteChan portSend + let bound = Binding ostr istr + void $ P.monitor portClient + unsafeSend portClient BindOk + return $ (routingTable ^: Map.insert portClient bound) x + + lookupBinding BroadcastEx{..} k = Map.lookup k $ _routingTable + +{- [note: pcopy] + +We rely on risky techniques here, in order to allow for sharing useful +data that is not really serializable. For Cloud Haskell generally, this is +a bad idea, since we want message passing to work both locally and in a +distributed setting. In this case however, what we're really attempting is +an optimisation, since we only use unsafe PCopy based techniques when dealing +with exchange clients residing on our (local) node. + +The PCopy mechanism is defined in the (aptly named) "Unsafe" module. + +-} + +-- TODO: move handleServerFailure into Primitives.hs + +writeToStream :: OutputStream -> Message -> Process () +writeToStream (WriteChan sp) = sendChan sp -- see [note: safe remote send] +writeToStream (WriteSTM stm) = liftIO . atomically . stm +writeToStream NoWrite = const $ return () +{-# INLINE writeToStream #-} + +{- [note: safe remote send] + +Although we go to great lengths here to avoid serialization and/or copying +overheads, there are some activities for which we prefer to play it safe. +Chief among these is delivering messages to remote clients. Thankfully, our +unsafe @sendChan@ primitive will crash the caller/sender if there are any +encoding problems, however it is only because we /know/ for certain that +our recipient is remote, that we've chosen to write via a SendPort in the +first place! It makes sense therefore, to use the safe @sendChan@ operation +here, since for a remote call we /cannot/ avoid the overhead of serialization +anyway. + +-} + +handleServerFailure :: MonitorRef -> Match (InputStream Message) +handleServerFailure mRef = + matchIf (\(ProcessMonitorNotification r _ _) -> r == mRef) + (\(ProcessMonitorNotification _ _ d) -> die $ ServerDisconnected d) + +routingTable :: Accessor BroadcastEx BroadcastClients +routingTable = accessor _routingTable (\r e -> e { _routingTable = r }) + diff --git a/packages/distributed-process-execution/src/Control/Distributed/Process/Execution/Exchange/Internal.hs b/packages/distributed-process-execution/src/Control/Distributed/Process/Execution/Exchange/Internal.hs new file mode 100644 index 00000000..6dfe8ee2 --- /dev/null +++ b/packages/distributed-process-execution/src/Control/Distributed/Process/Execution/Exchange/Internal.hs @@ -0,0 +1,275 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | Internal Exchange Implementation +module Control.Distributed.Process.Execution.Exchange.Internal + ( Exchange(..) + , Message(..) + , ExchangeType(..) + , startExchange + , startSupervised + , startSupervisedRef + , runExchange + , post + , postMessage + , configureExchange + , createMessage + , applyHandlers + ) where + +import Control.Concurrent.MVar (MVar, takeMVar, putMVar, newEmptyMVar) +import Control.DeepSeq (NFData) +import Control.Distributed.Process + ( Process + , ProcessMonitorNotification(..) + , ProcessId + , liftIO + , spawnLocal + , unsafeWrapMessage + ) +import qualified Control.Distributed.Process as P (Message, link) +import Control.Distributed.Process.Serializable hiding (SerializableDict) +import Control.Distributed.Process.Extras.Internal.Types + ( Resolvable(..) + ) +import Control.Distributed.Process.Extras.Internal.Primitives + ( Linkable(..) + ) +import Control.Distributed.Process.ManagedProcess + ( channelControlPort + , handleControlChan + , handleInfo + , handleRaw + , continue + , defaultProcess + , InitHandler + , InitResult(..) + , ProcessAction + , ProcessDefinition(..) + , ControlChannel + , ControlPort + ) +import qualified Control.Distributed.Process.ManagedProcess as MP + ( chanServe + ) +import Control.Distributed.Process.ManagedProcess.UnsafeClient + ( sendControlMessage + ) +import Control.Distributed.Process.Supervisor (SupervisorPid) +import Control.Distributed.Process.Extras.Time (Delay(Infinity)) +import Data.Binary +import Data.Typeable (Typeable) +import GHC.Generics +import Prelude hiding (drop) + +{- [design notes] + +Messages are sent to exchanges and forwarded to clients. An exchange +is parameterised by its routing mechanism, which is responsible for +maintaining its own client state and selecting the clients to which +messages are forwarded. + +-} + +-- | Opaque handle to an exchange. +-- +data Exchange = Exchange { pid :: !ProcessId + , cchan :: !(ControlPort ControlMessage) + , xType :: !String + } deriving (Typeable, Generic, Eq) +instance Binary Exchange where +instance Show Exchange where + show Exchange{..} = (xType ++ ":" ++ (show pid)) + +instance Resolvable Exchange where + resolve = return . Just . pid + +{- +instance Observable Exchange MonitorRef ProcessMonitorNotification where + observe = P.monitor . pid + unobserve = P.unmonitor + observableFrom ref (ProcessMonitorNotification ref' _ r) = + return $ if ref' == ref then Just r else Nothing +-} + +instance Linkable Exchange where + linkTo = P.link . pid + +-- we communicate with exchanges using control channels +sendCtrlMsg :: Exchange -> ControlMessage -> Process () +sendCtrlMsg Exchange{..} = sendControlMessage cchan + +-- | Messages sent to an exchange can optionally provide a routing +-- key and a list of (key, value) headers in addition to the underlying +-- payload. +data Message = + Message { key :: !String -- ^ a /routing key/ for the payload + , headers :: ![(String, String)] -- ^ arbitrary key-value headers + , payload :: !P.Message -- ^ the underlying @Message@ payload + } deriving (Typeable, Generic, Show) +instance Binary Message where +instance NFData Message where + +data ControlMessage = + Configure !P.Message + | Post !Message + deriving (Typeable, Generic) +instance Binary ControlMessage where +instance NFData ControlMessage where + +-- | Different exchange types are defined using record syntax. +-- The 'configureEx' and 'routeEx' API functions are called during the exchange +-- lifecycle when incoming traffic arrives. Configuration messages are +-- completely arbitrary types and the exchange type author is entirely +-- responsible for decoding them. Messages posted to the exchange (see the +-- 'Message' data type) are passed to the 'routeEx' API function along with the +-- exchange type's own internal state. Both API functions return a new +-- (potentially updated) state and run in the @Process@ monad. +-- +data ExchangeType s = + ExchangeType { name :: String + , state :: s + , configureEx :: s -> P.Message -> Process s + , routeEx :: s -> Message -> Process s + } + +-------------------------------------------------------------------------------- +-- Starting/Running an Exchange -- +-------------------------------------------------------------------------------- + +-- | Starts an /exchange process/ with the given 'ExchangeType'. +startExchange :: forall s. ExchangeType s -> Process Exchange +startExchange = doStart Nothing + +-- | Starts an exchange as part of a supervision tree. +-- +-- Example: +-- > childSpec = toChildStart $ startSupervisedRef exType +-- +startSupervisedRef :: forall s . ExchangeType s + -> SupervisorPid + -> Process (ProcessId, P.Message) +startSupervisedRef t s = do + ex <- startSupervised t s + return (pid ex, unsafeWrapMessage ex) + +-- | Starts an exchange as part of a supervision tree. +-- +-- Example: +-- > childSpec = toChildStart $ startSupervised exType +-- +startSupervised :: forall s . ExchangeType s + -> SupervisorPid + -> Process Exchange +startSupervised t s = doStart (Just s) t + +doStart :: Maybe SupervisorPid -> ExchangeType s -> Process Exchange +doStart mSp t = do + cchan <- liftIO $ newEmptyMVar + spawnLocal (maybeLink mSp >> runExchange t cchan) >>= \pid -> do + cc <- liftIO $ takeMVar cchan + return $ Exchange pid cc (name t) + where + maybeLink Nothing = return () + maybeLink (Just p') = P.link p' + +runExchange :: forall s. + ExchangeType s + -> MVar (ControlPort ControlMessage) + -> Process () +runExchange t tc = MP.chanServe t exInit (processDefinition t tc) + +exInit :: forall s. InitHandler (ExchangeType s) (ExchangeType s) +exInit t = return $ InitOk t Infinity + +-------------------------------------------------------------------------------- +-- Client Facing API -- +-------------------------------------------------------------------------------- + +-- | Posts an arbitrary 'Serializable' datum to an /exchange/. The raw datum is +-- wrapped in the 'Message' data type, with its 'key' set to @""@ and its +-- 'headers' to @[]@. +post :: Serializable a => Exchange -> a -> Process () +post ex msg = postMessage ex $ Message "" [] (unsafeWrapMessage msg) + +-- | Posts a 'Message' to an /exchange/. +postMessage :: Exchange -> Message -> Process () +postMessage ex msg = msg `seq` sendCtrlMsg ex $ Post msg + +-- | Sends an arbitrary 'Serializable' datum to an /exchange/, for use as a +-- configuration change - see 'configureEx' for details. +configureExchange :: Serializable m => Exchange -> m -> Process () +configureExchange e m = sendCtrlMsg e $ Configure (unsafeWrapMessage m) + +-- | Utility for creating a 'Message' datum from its 'key', 'headers' and +-- 'payload'. +createMessage :: Serializable m => String -> [(String, String)] -> m -> Message +createMessage k h m = Message k h $ unsafeWrapMessage m + +-- | Utility for custom exchange type authors - evaluates a set of primitive +-- message handlers from left to right, returning the first which evaluates +-- to @Just a@, or the initial @e@ value if all the handlers yield @Nothing@. +applyHandlers :: a + -> P.Message + -> [P.Message -> Process (Maybe a)] + -> Process a +applyHandlers e _ [] = return e +applyHandlers e m (f:fs) = do + r <- f m + case r of + Nothing -> applyHandlers e m fs + Just r' -> return r' + +-------------------------------------------------------------------------------- +-- Process Definition/State & API Handlers -- +-------------------------------------------------------------------------------- + +processDefinition :: forall s. + ExchangeType s + -> MVar (ControlPort ControlMessage) + -> ControlChannel ControlMessage + -> Process (ProcessDefinition (ExchangeType s)) +processDefinition _ tc cc = do + liftIO $ putMVar tc $ channelControlPort cc + return $ + defaultProcess { + externHandlers = [ handleControlChan cc handleControlMessage ] + , infoHandlers = [ handleInfo handleMonitor + , handleRaw convertToCC + ] + } :: Process (ProcessDefinition (ExchangeType s)) + +handleMonitor :: forall s. + ExchangeType s + -> ProcessMonitorNotification + -> Process (ProcessAction (ExchangeType s)) +handleMonitor ex m = do + handleControlMessage ex (Configure (unsafeWrapMessage m)) + +convertToCC :: forall s. + ExchangeType s + -> P.Message + -> Process (ProcessAction (ExchangeType s)) +convertToCC ex msg = do + liftIO $ putStrLn "convert to cc" + handleControlMessage ex (Post $ Message "" [] msg) + +handleControlMessage :: forall s. + ExchangeType s + -> ControlMessage + -> Process (ProcessAction (ExchangeType s)) +handleControlMessage ex@ExchangeType{..} cm = + let action = case cm of + Configure msg -> configureEx state msg + Post msg -> routeEx state msg + in action >>= \s -> continue $ ex { state = s } diff --git a/packages/distributed-process-execution/src/Control/Distributed/Process/Execution/Exchange/Router.hs b/packages/distributed-process-execution/src/Control/Distributed/Process/Execution/Exchange/Router.hs new file mode 100644 index 00000000..efdaeb4f --- /dev/null +++ b/packages/distributed-process-execution/src/Control/Distributed/Process/Execution/Exchange/Router.hs @@ -0,0 +1,250 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | A simple API for /routing/, using a custom exchange type. +module Control.Distributed.Process.Execution.Exchange.Router + ( -- * Types + HeaderName + , Binding(..) + , Bindable + , BindingSelector + , RelayType(..) + -- * Starting a Router + , router + , supervisedRouter + , supervisedRouterRef + -- * Client (Publishing) API + , route + , routeMessage + -- * Routing via message/binding keys + , messageKeyRouter + , bindKey + -- * Routing via message headers + , headerContentRouter + , bindHeader + ) where + +import Control.DeepSeq (NFData) +import Control.Distributed.Process + ( Process + , ProcessMonitorNotification(..) + , ProcessId + , monitor + , handleMessage + , unsafeWrapMessage + ) +import qualified Control.Distributed.Process as P +import Control.Distributed.Process.Serializable (Serializable) +import Control.Distributed.Process.Execution.Exchange.Internal + ( startExchange + , startSupervised + , configureExchange + , Message(..) + , Exchange + , ExchangeType(..) + , post + , postMessage + , applyHandlers + ) +import Control.Distributed.Process.Extras.Internal.Primitives + ( deliver + , Resolvable(..) + ) +import Control.Distributed.Process.Supervisor (SupervisorPid) +import Data.Binary +import Data.Foldable (forM_) +import Data.Hashable +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as Map +import Data.HashSet (HashSet) +import qualified Data.HashSet as Set +import Data.Typeable (Typeable) +import GHC.Generics + +type HeaderName = String + +-- | The binding key used by the built-in key and header based +-- routers. +data Binding = + BindKey { bindingKey :: !String } + | BindHeader { bindingKey :: !String + , headerName :: !HeaderName + } + | BindNone + deriving (Typeable, Generic, Eq, Show) +instance Binary Binding where +instance NFData Binding where +instance Hashable Binding where + +-- | Things that can be used as binding keys in a router. +class (Hashable k, Eq k, Serializable k) => Bindable k +instance (Hashable k, Eq k, Serializable k) => Bindable k + +-- | Used to convert a 'Message' into a 'Bindable' routing key. +type BindingSelector k = (Message -> Process k) + +-- | Given to a /router/ to indicate whether clients should +-- receive 'Message' payloads only, or the whole 'Message' object +-- itself. +data RelayType = PayloadOnly | WholeMessage + +data State k = State { bindings :: !(HashMap k (HashSet ProcessId)) + , selector :: !(BindingSelector k) + , relayType :: !RelayType + } + +type Router k = ExchangeType (State k) + +-------------------------------------------------------------------------------- +-- Starting/Running the Exchange -- +-------------------------------------------------------------------------------- + +-- | A router that matches on a 'Message' 'key'. To bind a client @Process@ to +-- such an exchange, use the 'bindKey' function. +messageKeyRouter :: RelayType -> Process Exchange +messageKeyRouter t = router t matchOnKey -- (return . BindKey . key) + where + matchOnKey :: Message -> Process Binding + matchOnKey m = return $ BindKey (key m) + +-- | A router that matches on a specific (named) header. To bind a client +-- @Process@ to such an exchange, use the 'bindHeader' function. +headerContentRouter :: RelayType -> HeaderName -> Process Exchange +headerContentRouter t n = router t (checkHeaders n) + where + checkHeaders hn Message{..} = do + case Map.lookup hn (Map.fromList headers) of + Nothing -> return BindNone + Just hv -> return $ BindHeader hn hv + +-- | Defines a /router/ exchange. The 'BindingSelector' is used to construct +-- a binding (i.e., an instance of the 'Bindable' type @k@) for each incoming +-- 'Message'. Such bindings are matched against bindings stored in the exchange. +-- Clients of a /router/ exchange are identified by a binding, mapped to +-- one or more 'ProcessId's. +-- +-- The format of the bindings, nature of their storage and mechanism for +-- submitting new bindings is implementation dependent (i.e., will vary by +-- exchange type). For example, the 'messageKeyRouter' and 'headerContentRouter' +-- implementations both use the 'Binding' data type, which can represent a +-- 'Message' key or a 'HeaderName' and content. As with all custom exchange +-- types, bindings should be submitted by evaluating 'configureExchange' with +-- a suitable data type. +-- +router :: (Bindable k) => RelayType -> BindingSelector k -> Process Exchange +router t s = routerT t s >>= startExchange + +supervisedRouterRef :: Bindable k + => RelayType + -> BindingSelector k + -> SupervisorPid + -> Process (ProcessId, P.Message) +supervisedRouterRef t sel spid = do + ex <- supervisedRouter t sel spid + Just pid <- resolve ex + return (pid, unsafeWrapMessage ex) + +-- | Defines a /router/ that can be used in a supervision tree. +supervisedRouter :: Bindable k + => RelayType + -> BindingSelector k + -> SupervisorPid + -> Process Exchange +supervisedRouter t sel spid = + routerT t sel >>= \t' -> startSupervised t' spid + +routerT :: Bindable k + => RelayType + -> BindingSelector k + -> Process (Router k) +routerT t s = do + return $ ExchangeType { name = "Router" + , state = State Map.empty s t + , configureEx = apiConfigure + , routeEx = apiRoute + } + +-------------------------------------------------------------------------------- +-- Client Facing API -- +-------------------------------------------------------------------------------- + +-- | Add a binding (for the calling process) to a 'messageKeyRouter' exchange. +bindKey :: String -> Exchange -> Process () +bindKey k ex = do + self <- P.getSelfPid + configureExchange ex (self, BindKey k) + +-- | Add a binding (for the calling process) to a 'headerContentRouter' exchange. +bindHeader :: HeaderName -> String -> Exchange -> Process () +bindHeader n v ex = do + self <- P.getSelfPid + configureExchange ex (self, BindHeader v n) + +-- | Send a 'Serializable' message to the supplied 'Exchange'. The given datum +-- will be converted to a 'Message', with the 'key' set to @""@ and the +-- 'headers' to @[]@. +-- +-- The routing behaviour will be dependent on the choice of 'BindingSelector' +-- given when initialising the /router/. +route :: Serializable m => Exchange -> m -> Process () +route = post + +-- | Send a 'Message' to the supplied 'Exchange'. +-- The routing behaviour will be dependent on the choice of 'BindingSelector' +-- given when initialising the /router/. +routeMessage :: Exchange -> Message -> Process () +routeMessage = postMessage + +-------------------------------------------------------------------------------- +-- Exchage Definition/State & API Handlers -- +-------------------------------------------------------------------------------- + +apiRoute :: forall k. Bindable k + => State k + -> Message + -> Process (State k) +apiRoute st@State{..} msg = do + binding <- selector msg + case Map.lookup binding bindings of + Nothing -> return st + Just bs -> forM_ bs (fwd relayType msg) >> return st + where + fwd WholeMessage m = deliver m + fwd PayloadOnly m = P.forward (payload m) + +-- TODO: implement 'unbind' ??? +-- TODO: apiConfigure currently leaks memory if clients die (we don't cleanup) + +apiConfigure :: forall k. Bindable k + => State k + -> P.Message + -> Process (State k) +apiConfigure st msg = do + applyHandlers st msg $ [ \m -> handleMessage m (createBinding st) + , \m -> handleMessage m (handleMonitorSignal st) + ] + where + createBinding s@State{..} (pid, bind) = do + case Map.lookup bind bindings of + Nothing -> do _ <- monitor pid + return $ s { bindings = newBind bind pid bindings } + Just ps -> return $ s { bindings = addBind bind pid bindings ps } + + newBind b p bs = Map.insert b (Set.singleton p) bs + addBind b' p' bs' ps = Map.insert b' (Set.insert p' ps) bs' + + handleMonitorSignal s@State{..} (ProcessMonitorNotification _ p _) = + let bs = bindings + bs' = Map.foldlWithKey' (\a k v -> Map.insert k (Set.delete p v) a) bs bs + in return $ s { bindings = bs' } + diff --git a/packages/distributed-process-execution/src/Control/Distributed/Process/Execution/Mailbox.hs b/packages/distributed-process-execution/src/Control/Distributed/Process/Execution/Mailbox.hs new file mode 100644 index 00000000..6b1d7b29 --- /dev/null +++ b/packages/distributed-process-execution/src/Control/Distributed/Process/Execution/Mailbox.hs @@ -0,0 +1,742 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ImpredicativeTypes #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Distributed.Process.Execution.Mailbox +-- Copyright : (c) Tim Watson 2012 - 2013 +-- License : BSD3 (see the file LICENSE) +-- +-- Maintainer : Tim Watson +-- Stability : experimental +-- Portability : non-portable (requires concurrency) +-- +-- Generic process that acts as an external mailbox and message buffer. +-- +-- [Overview] +-- +-- For use when rate limiting is not possible (or desired), this module +-- provides a /buffer process/ that receives mail via its 'post' API, buffers +-- the received messages and delivers them when its /owning process/ asks for +-- them. A mailbox has to be started with a maximum buffer size - the so called +-- /limit/ - and will discard messages once its internal storage reaches this +-- user defined threshold. +-- +-- The usual behaviour of the /buffer process/ is to accumulate messages in +-- its internal memory. When a client evaluates 'notify', the buffer will +-- send a 'NewMail' message to the (real) mailbox of its owning process as +-- soon as it has any message(s) ready to deliver. If the buffer already +-- contains undelivered mail, the 'NewMail' message will be dispatched +-- immediately. +-- +-- When the owning process wishes to receive mail, evaluating 'deliver' (from +-- any process) will cause the buffer to send its owner a 'Delivery' message +-- containing the accumulated messages and additional information about the +-- number of messages it is delivering, the number of messages dropped since +-- the last delivery and a handle for the mailbox (so that processes can have +-- multiple mailboxes if required, and distinguish between them). +-- +-- [Overflow Handling] +-- +-- A mailbox handles overflow - when the number of messages it is holding +-- reaches the limit - differently depending on the 'BufferType' selected +-- when it starts. The @Queue@ buffer will, once the limit is reached, drop +-- older messages first (i.e., the head of the queue) to make space for +-- newer ones. The @Ring@ buffer works similarly, but blocks new messages +-- so as to preserve existing ones instead. Finally, the @Stack@ buffer will +-- drop the last (i.e., most recently received) message to make room for new +-- mail. +-- +-- Mailboxes can be /resized/ by evaluating 'resize' with a new value for the +-- limit. If the new limit is older that the current/previous one, messages +-- are dropped as though the mailbox had previously seen a volume of mail +-- equal to the difference (in size) between the limits. In this situation, +-- the @Queue@ will drop as many older messages as neccessary to come within +-- the limit, whilst the other two buffer types will drop as many newer messages +-- as needed. +-- +-- [Ordering Guarantees] +-- +-- When messages are delivered to the owner, they arrive as a list of raw +-- @Message@ entries, given in descending age order (i.e., eldest first). +-- Whilst this approximates the FIFO ordering a process' mailbox would usually +-- offer, the @Stack@ buffer will appear to offer no ordering at all, since +-- it always deletes the most recent message(s). The @Queue@ and @Ring@ buffers +-- will maintain a more queue-like (i.e., FIFO) view of received messages, +-- with the obvious constraint the newer or older data might have been deleted. +-- +-- [Post API and Relaying] +-- +-- For messages to be properly handled by the mailbox, they can either be sent +-- via the 'post' API or directly to the 'Mailbox'. Messages sent directly to +-- the mailbox will still be handled via the internal buffers and subjected to +-- the mailbox limits. The 'post' API is really just a means to ensure that +-- the conversion from @Serializable a -> Message@ is done in the caller's +-- process and uses the safe @wrapMessage@ variant. +-- +-- [Acknowledgements] +-- +-- This API is based on the work of Erlang programmers Fred Hebert and +-- Geoff Cant, its design closely mirroring that of the the /pobox/ library +-- application. +-- +----------------------------------------------------------------------------- +module Control.Distributed.Process.Execution.Mailbox + ( + -- * Creating, Starting, Configuring and Running a Mailbox + Mailbox() + , startMailbox + , startSupervised + , startSupervisedMailbox + , createMailbox + , resize + , statistics + , monitor + , Limit + , BufferType(..) + , MailboxStats(..) + -- * Posting Mail + , post + -- * Obtaining Mail and Notifications + , notify + , deliver + , active + , NewMail(..) + , Delivery(..) + , FilterResult(..) + , acceptEverything + , acceptMatching + -- * Remote Table + , __remoteTable + ) where + +import Control.Concurrent.STM (atomically) +import Control.Concurrent.STM.TChan + ( TChan + , newBroadcastTChanIO + , dupTChan + , readTChan + , writeTChan + ) +import Control.Distributed.Process hiding (call, monitor) +import qualified Control.Distributed.Process as P (monitor) +import Control.Distributed.Process.Closure + ( remotable + , mkStaticClosure + ) +import Control.Distributed.Process.Serializable hiding (SerializableDict) +import Control.Distributed.Process.Extras + ( ExitReason(..) + , Resolvable(..) + , Routable(..) + , Linkable(..) + , Addressable + ) +import Control.Distributed.Process.ManagedProcess + ( call + , sendControlMessage + , channelControlPort + , handleControlChan + , handleInfo + , handleRaw + , continue + , defaultProcess + , UnhandledMessagePolicy(..) + , InitHandler + , InitResult(..) + , ProcessAction + , ProcessDefinition(..) + , ControlChannel + , ControlPort + ) +import qualified Control.Distributed.Process.ManagedProcess as MP + ( chanServe + ) +import Control.Distributed.Process.ManagedProcess.Server + ( stop + ) +import Control.Distributed.Process.ManagedProcess.Server.Restricted as Restricted + ( getState + , Result + , RestrictedProcess + ) +import qualified Control.Distributed.Process.ManagedProcess.Server.Restricted as Restricted + ( handleCall + , reply + ) +import Control.Distributed.Process.Supervisor (SupervisorPid) +import Control.Distributed.Process.Extras.Time +import Control.Exception (SomeException) +import Data.Accessor + ( Accessor + , accessor + , (^:) + , (.>) + , (^=) + , (^.) + ) +import Data.Binary +import qualified Data.Foldable as Foldable +import Data.Sequence + ( Seq + , ViewL(EmptyL, (:<)) + , ViewR(EmptyR, (:>)) + , (<|) + , (|>) + ) +import qualified Data.Sequence as Seq +import Data.Typeable (Typeable) + +import GHC.Generics + +import Prelude hiding (drop) + +-------------------------------------------------------------------------------- +-- Types -- +-------------------------------------------------------------------------------- + +-- external client/configuration API + +-- | Opaque handle to a mailbox. +-- +data Mailbox = Mailbox { pid :: !ProcessId + , cchan :: !(ControlPort ControlMessage) + } deriving (Typeable, Generic, Eq) +instance Binary Mailbox where +instance Show Mailbox where + show = ("Mailbox:" ++) . show . pid + +instance Linkable Mailbox where + linkTo = link . pid + +instance Resolvable Mailbox where + resolve = return . Just . pid + +instance Routable Mailbox where + sendTo = post + unsafeSendTo = post + +instance Addressable Mailbox + +sendCtrlMsg :: Mailbox + -> ControlMessage + -> Process () +sendCtrlMsg Mailbox{..} = sendControlMessage cchan + +-- | Describes the different types of buffer. +-- +data BufferType = + Queue -- ^ FIFO buffer, limiter drops the eldest message (queue head) + | Stack -- ^ unordered buffer, limiter drops the newest (top) message + | Ring -- ^ FIFO buffer, limiter refuses (i.e., drops) new messages + deriving (Typeable, Eq, Show) + +-- TODO: re-implement this process in terms of a limiter expression, i.e., +-- +-- data Limit s = Accept s | Block s +-- +-- limit :: forall s. Closure (Message {- new mail -} -> Process (Limit s)) + +-- | Represents the maximum number of messages the internal buffer can hold. +-- +type Limit = Integer + +-- | A @Closure@ used to filter messages in /active/ mode. +-- +type Filter = Closure (Message -> Process FilterResult) + +-- | Marker message indicating to the owning process that mail has arrived. +-- +data NewMail = NewMail !Mailbox !Integer + deriving (Typeable, Generic, Show) +instance Binary NewMail where + +-- | Mail delivery. +-- +data Delivery = Delivery { box :: Mailbox -- ^ handle to the sending mailbox + , messages :: [Message] -- ^ list of raw messages + , count :: Integer -- ^ number of messages delivered + , totalDropped :: Integer -- ^ total dropped/skipped messages + } + deriving (Typeable, Generic) +instance Binary Delivery where + +-- TODO: keep running totals and send them with the stats... + +-- | Bundle of statistics data, available on request via +-- the 'mailboxStats' API call. +-- +data MailboxStats = + MailboxStats { pendingMessages :: Integer + , droppedMessages :: Integer + , currentLimit :: Limit + , owningProcess :: ProcessId + } deriving (Typeable, Generic, Show) +instance Binary MailboxStats where + +-- internal APIs + +data Post = Post !Message + deriving (Typeable, Generic) +instance Binary Post where + +data StatsReq = StatsReq + deriving (Typeable, Generic) +instance Binary StatsReq where + +data FilterResult = Keep | Skip | Send + deriving (Typeable, Generic) +instance Binary FilterResult + +data Mode = + Active !Filter -- ^ Send all buffered messages (or wait until one arrives) + | Notify -- ^ Send a notification once messages are ready to be received + | Passive -- ^ Accumulate messages in the buffer, dropping them if necessary + deriving (Typeable, Generic) +instance Binary Mode where +instance Show Mode where + show (Active _) = "Active" + show Notify = "Notify" + show Passive = "Passive" + +data ControlMessage = + Resize !Integer + | SetActiveMode !Mode + deriving (Typeable, Generic) +instance Binary ControlMessage where + +class Buffered a where + tag :: a -> BufferType + push :: Message -> a -> a + pop :: a -> Maybe (Message, a) + adjust :: Limit -> a -> a + drop :: Integer -> a -> a + +data BufferState = + BufferState { _mode :: Mode + , _bufferT :: BufferType + , _limit :: Limit + , _size :: Integer + , _dropped :: Integer + , _owner :: ProcessId + , ctrlChan :: ControlPort ControlMessage + } + +defaultState :: BufferType + -> Limit + -> ProcessId + -> ControlPort ControlMessage + -> BufferState +defaultState bufferT limit' pid cc = + BufferState { _mode = Passive + , _bufferT = bufferT + , _limit = limit' + , _size = 0 + , _dropped = 0 + , _owner = pid + , ctrlChan = cc + } + +data State = State { _buffer :: Seq Message + , _state :: BufferState + } + +instance Buffered State where + tag q = _bufferT $ _state q + + -- see note [buffer enqueue/dequeue semantics] + push m = (state .> size ^: (+1)) . (buffer ^: (m <|)) + + -- see note [buffer enqueue/dequeue semantics] + pop q = maybe Nothing + (\(s' :> a) -> Just (a, ( (buffer ^= s') + . (state .> size ^: (1-)) + $ q))) $ getR (q ^. buffer) + + adjust sz q = (state .> limit ^= sz) $ maybeDrop + where + maybeDrop + | size' <- (q ^. state ^. size), + size' > sz = (state .> size ^= sz) $ drop (size' - sz) q + | otherwise = q + + -- see note [buffer drop semantics] + drop n q + | n > 1 = drop (n - 1) $ drop 1 q + | isQueue q = dropR q + | otherwise = dropL q + where + dropR q' = maybe q' (\(s' :> _) -> dropOne q' s') $ getR (q' ^. buffer) + dropL q' = maybe q' (\(_ :< s') -> dropOne q' s') $ getL (q' ^. buffer) + dropOne q' s = ( (buffer ^= s) + . (state .> size ^: (\n' -> n' - 1)) + . (state .> dropped ^: (+1)) + $ q' ) + +{- note [buffer enqueue/dequeue semantics] +If we choose to add a message to the buffer, it is always +added to the left hand side of the sequence. This gives +FIFO (enqueue to tail) semantics for queues, LIFO (push +new head) semantics for stacks when dropping messages - note +that dequeueing will always take the eldest (RHS) message, +regardless of the buffer type - and queue-like semantics for +the ring buffer. + +We /always/ take the eldest message each time we dequeue, +in an attempt to maintain something approaching FIFO order +when processing the mailbox, for all data structures. Where +we do not achieve this is dropping messages, since the different +buffer types drop messages either on the right (eldest) or left +(youngest). + +-- note [buffer drop semantics] + +The "stack buffer", when full, only ever attempts to drop the +youngest (leftmost) message, such that it guarantees no ordering +at all, but that is enforced by the code calling 'drop' rather +than the data structure itself. The ring buffer behaves similarly, +since it rejects new messages altogether, which in practise means +dropping from the LHS. + +-} + +-------------------------------------------------------------------------------- +-- Starting/Running a Mailbox -- +-------------------------------------------------------------------------------- + +-- | Start a mailbox for the calling process. +-- +-- > create = getSelfPid >>= start +-- +createMailbox :: BufferType -> Limit -> Process Mailbox +createMailbox buffT maxSz = + getSelfPid >>= \self -> startMailbox self buffT maxSz + +-- | Start a mailbox for the supplied @ProcessId@. +-- +-- > start = spawnLocal $ run +-- +startMailbox :: ProcessId -> BufferType -> Limit -> Process Mailbox +startMailbox = doStartMailbox Nothing + +-- | As 'startMailbox', but suitable for use in supervisor child specs. +-- This variant is for use when you want to access to the underlying +-- 'Mailbox' handle in your supervised child refs. See supervisor's +-- @ChildRef@ data type for more information. +-- +-- Example: +-- > childSpec = toChildStart $ startSupervised pid bufferType mboxLimit +-- +-- See "Control.Distributed.Process.Supervisor" +-- +startSupervised :: ProcessId + -> BufferType + -> Limit + -> SupervisorPid + -> Process (ProcessId, Message) +startSupervised p b l s = do + mb <- startSupervisedMailbox p b l s + return (pid mb, unsafeWrapMessage mb) + +-- | As 'startMailbox', but suitable for use in supervisor child specs. +-- +-- See "Control.Distributed.Process.Supervisor" +-- +startSupervisedMailbox :: ProcessId + -> BufferType + -> Limit + -> SupervisorPid + -> Process Mailbox +startSupervisedMailbox p b l s = doStartMailbox (Just s) p b l + +doStartMailbox :: Maybe SupervisorPid + -> ProcessId + -> BufferType + -> Limit + -> Process Mailbox +doStartMailbox mSp p b l = do + bchan <- liftIO $ newBroadcastTChanIO + rchan <- liftIO $ atomically $ dupTChan bchan + spawnLocal (maybeLink mSp >> runMailbox bchan p b l) >>= \pid -> do + cc <- liftIO $ atomically $ readTChan rchan + return $ Mailbox pid cc + where + maybeLink Nothing = return () + maybeLink (Just p') = link p' + +-- | Run the mailbox server loop. +-- +runMailbox :: TChan (ControlPort ControlMessage) + -> ProcessId + -> BufferType + -> Limit + -> Process () +runMailbox tc pid buffT maxSz = do + link pid + tc' <- liftIO $ atomically $ dupTChan tc + MP.chanServe (pid, buffT, maxSz) (mboxInit tc') (processDefinition pid tc) + +-------------------------------------------------------------------------------- +-- Mailbox Initialisation/Startup -- +-------------------------------------------------------------------------------- + +mboxInit :: TChan (ControlPort ControlMessage) + -> InitHandler (ProcessId, BufferType, Limit) State +mboxInit tc (pid, buffT, maxSz) = do + cc <- liftIO $ atomically $ readTChan tc + return $ InitOk (State Seq.empty $ defaultState buffT maxSz pid cc) Infinity + +-------------------------------------------------------------------------------- +-- Client Facing API -- +-------------------------------------------------------------------------------- + +-- | Monitor a mailbox. +-- +monitor :: Mailbox -> Process MonitorRef +monitor = P.monitor . pid + +-- | Instructs the mailbox to send a 'NewMail' signal as soon as any mail is +-- available for delivery. Once the signal is sent, it will not be resent, even +-- when further mail arrives, until 'notify' is called again. +-- +-- NB: signals are /only/ delivered to the mailbox's owning process. +-- +notify :: Mailbox -> Process () +notify mb = sendCtrlMsg mb $ SetActiveMode Notify + +-- | Instructs the mailbox to send a 'Delivery' as soon as any mail is +-- available, or immediately (if the buffer already contains data). +-- +-- NB: signals are /only/ delivered to the mailbox's owning process. +-- +active :: Mailbox -> Filter -> Process () +active mb f = sendCtrlMsg mb $ SetActiveMode $ Active f + +-- | Alters the mailbox's /limit/ - this might cause messages to be dropped! +-- +resize :: Mailbox -> Integer -> Process () +resize mb sz = sendCtrlMsg mb $ Resize sz + +-- | Posts a message to someone's mailbox. +-- +post :: Serializable a => Mailbox -> a -> Process () +post Mailbox{..} m = send pid (Post $ wrapMessage m) + +-- | Obtain statistics (from/to anywhere) about a mailbox. +-- +statistics :: Mailbox -> Process MailboxStats +statistics mb = call mb StatsReq + +-------------------------------------------------------------------------------- +-- PRIVATE Filter Implementation(s) -- +-------------------------------------------------------------------------------- + +everything :: Message -> Process FilterResult +everything _ = return Keep + +matching :: Closure (Message -> Process FilterResult) + -> Message + -> Process FilterResult +matching predicate msg = do + pred' <- unClosure predicate :: Process (Message -> Process FilterResult) + res <- handleMessage msg pred' + case res of + Nothing -> return Skip + Just fr -> return fr + +-------------------------------------------------------------------------------- +-- Process Definition/State & API Handlers -- +-------------------------------------------------------------------------------- + +processDefinition :: ProcessId + -> TChan (ControlPort ControlMessage) + -> ControlChannel ControlMessage + -> Process (ProcessDefinition State) +processDefinition pid tc cc = do + liftIO $ atomically $ writeTChan tc $ channelControlPort cc + return $ defaultProcess { apiHandlers = [ + Restricted.handleCall handleGetStats + ] + , externHandlers = [ + handleControlChan cc handleControlMessages + ] + , infoHandlers = [ handleInfo handlePost + , handleRaw handleRawInputs ] + , unhandledMessagePolicy = DeadLetter pid + } :: Process (ProcessDefinition State) + +handleControlMessages :: State + -> ControlMessage + -> Process (ProcessAction State) +handleControlMessages st cm + | (SetActiveMode new) <- cm = activateMode st new + | (Resize sz') <- cm = continue $ adjust sz' st + | otherwise = stop $ ExitOther "IllegalState" + where + activateMode :: State -> Mode -> Process (ProcessAction State) + activateMode st' new + | sz <- (st ^. state ^. size) + , sz == 0 = continue $ updated st' new + | otherwise = do + let updated' = updated st' new + case new of + Notify -> sendNotification updated' >> continue updated' + (Active _) -> sendMail updated' >>= continue + Passive -> {- shouldn't happen! -} die $ "IllegalState" + + updated s m = (state .> mode ^= m) s + +handleGetStats :: StatsReq -> RestrictedProcess State (Result MailboxStats) +handleGetStats _ = Restricted.reply . (^. stats) =<< getState + +handleRawInputs :: State -> Message -> Process (ProcessAction State) +handleRawInputs st msg = handlePost st (Post msg) + +handlePost :: State -> Post -> Process (ProcessAction State) +handlePost st (Post msg) = do + let st' = insert msg st + continue . (state .> mode ^= Passive) =<< forwardIfNecessary st' + where + forwardIfNecessary s + | Notify <- currentMode = sendNotification s >> return s + | Active _ <- currentMode = sendMail s + | otherwise = return s + + currentMode = st ^. state ^. mode + +-------------------------------------------------------------------------------- +-- Accessors, State/Stats Management & Utilities -- +-------------------------------------------------------------------------------- + +sendNotification :: State -> Process () +sendNotification st = do + pid <- getSelfPid + send ownerPid $ NewMail (Mailbox pid cchan) pending + where + ownerPid = st ^. state ^. owner + pending = st ^. state ^. size + cchan = ctrlChan (st ^. state) + +type Count = Integer +type Skipped = Integer + +sendMail :: State -> Process State +sendMail st = do + let Active f = st ^. state ^. mode + unCl <- catch (unClosure f >>= return . Just) + (\(_ :: SomeException) -> return Nothing) + case unCl of + Nothing -> return st -- TODO: Logging!? + Just f' -> do + (st', cnt, skipped, msgs) <- applyFilter f' st + us <- getSelfPid + send ownerPid $ Delivery { box = Mailbox us (ctrlChan $ st ^. state) + , messages = Foldable.toList msgs + , count = cnt + , totalDropped = skipped + droppedMsgs + } + return $ ( (state .> dropped ^= 0) + . (state .> size ^: ((cnt + skipped) -)) + $ st' ) + where + applyFilter f s = filterMessages f (s, 0, 0, Seq.empty) + + filterMessages :: (Message -> Process FilterResult) + -> (State, Count, Skipped, Seq Message) + -> Process (State, Count, Skipped, Seq Message) + filterMessages f accIn@(buff, cnt, drp, acc) = do + case pop buff of + Nothing -> return accIn + Just (m, buff') -> do + res <- f m + case res of + Keep -> filterMessages f (buff', cnt + 1, drp, acc |> m) + Skip -> filterMessages f (buff', cnt, drp + 1, acc) + Send -> return accIn + + ownerPid = st ^. state ^. owner + droppedMsgs = st ^. state ^. dropped + +insert :: Message -> State -> State +insert msg st@(State _ BufferState{..}) = + if _size /= _limit + then push msg st + else case _bufferT of + Ring -> (state .> dropped ^: (+1)) st + _ -> push msg $ drop 1 st + +isQueue :: State -> Bool +isQueue = (== Queue) . _bufferT . _state + +isStack :: State -> Bool +isStack = (== Stack) . _bufferT . _state + +getR :: Seq a -> Maybe (ViewR a) +getR s = + case Seq.viewr s of + EmptyR -> Nothing + a -> Just a + +getL :: Seq a -> Maybe (ViewL a) +getL s = + case Seq.viewl s of + EmptyL -> Nothing + a -> Just a + +mode :: Accessor BufferState Mode +mode = accessor _mode (\m st -> st { _mode = m }) + +bufferType :: Accessor BufferState BufferType +bufferType = accessor _bufferT (\t st -> st { _bufferT = t }) + +limit :: Accessor BufferState Limit +limit = accessor _limit (\l st -> st { _limit = l }) + +size :: Accessor BufferState Integer +size = accessor _size (\s st -> st { _size = s }) + +dropped :: Accessor BufferState Integer +dropped = accessor _dropped (\d st -> st { _dropped = d }) + +owner :: Accessor BufferState ProcessId +owner = accessor _owner (\o st -> st { _owner = o }) + +buffer :: Accessor State (Seq Message) +buffer = accessor _buffer (\b qb -> qb { _buffer = b }) + +state :: Accessor State BufferState +state = accessor _state (\s qb -> qb { _state = s }) + +stats :: Accessor State MailboxStats +stats = accessor getStats (\_ s -> s) -- TODO: use a READ ONLY accessor for this + where + getStats (State _ (BufferState _ _ lm sz dr op _)) = MailboxStats sz dr lm op + +$(remotable ['everything, 'matching]) + +-- | A /do-nothing/ filter that accepts all messages (i.e., returns @Keep@ +-- for any input). +acceptEverything :: Closure (Message -> Process FilterResult) +acceptEverything = $(mkStaticClosure 'everything) + +-- | A filter that takes a @Closure (Message -> Process FilterResult)@ holding +-- the filter function and applies it remotely (i.e., in the mailbox's own +-- managed process). +-- +acceptMatching :: Closure (Closure (Message -> Process FilterResult) + -> Message -> Process FilterResult) +acceptMatching = $(mkStaticClosure 'matching) + +-- | Instructs the mailbox to deliver all pending messages to the owner. +-- +deliver :: Mailbox -> Process () +deliver mb = active mb acceptEverything diff --git a/packages/distributed-process-execution/test-report.hs b/packages/distributed-process-execution/test-report.hs new file mode 100755 index 00000000..523ecf79 --- /dev/null +++ b/packages/distributed-process-execution/test-report.hs @@ -0,0 +1,10 @@ +#! /bin/sh + +HPC_DIR=dist/hpc + +cabal-dev clean +cabal-dev configure --enable-tests --enable-library-coverage +cabal-dev build +cabal-dev test + +open ${HPC_DIR}/html/*/hpc-index.html diff --git a/packages/distributed-process-execution/tests/MailboxTestFilters.hs b/packages/distributed-process-execution/tests/MailboxTestFilters.hs new file mode 100644 index 00000000..ca17ffae --- /dev/null +++ b/packages/distributed-process-execution/tests/MailboxTestFilters.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module MailboxTestFilters where + +import Control.Distributed.Process +import Control.Distributed.Process.Execution.Mailbox (FilterResult(..)) +import Control.Monad (forM) + +import Prelude hiding (drop) +import Data.Maybe (catMaybes) +import Control.Distributed.Process.Closure (remotable, mkClosure, mkStaticClosure) + +filterInputs :: (String, Int, Bool) -> Message -> Process FilterResult +filterInputs (s, i, b) msg = do + rs <- forM [ \m -> handleMessageIf m (\s' -> s' == s) (\_ -> return Keep) + , \m -> handleMessageIf m (\i' -> i' == i) (\_ -> return Keep) + , \m -> handleMessageIf m (\b' -> b' == b) (\_ -> return Keep) + ] $ \h -> h msg + if (length (catMaybes rs) > 0) + then return Keep + else return Skip + +filterEvens :: Message -> Process FilterResult +filterEvens m = do + matched <- handleMessage m (\(i :: Int) -> do + if even i then return Keep else return Skip) + case matched of + Just fr -> return fr + _ -> return Skip + +$(remotable ['filterInputs, 'filterEvens]) + +intFilter :: Closure (Message -> Process FilterResult) +intFilter = $(mkStaticClosure 'filterEvens) + +myFilter :: (String, Int, Bool) -> Closure (Message -> Process FilterResult) +myFilter = $(mkClosure 'filterInputs) + diff --git a/packages/distributed-process-execution/tests/TestExchange.hs b/packages/distributed-process-execution/tests/TestExchange.hs new file mode 100644 index 00000000..088753af --- /dev/null +++ b/packages/distributed-process-execution/tests/TestExchange.hs @@ -0,0 +1,190 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Main where + +import Control.Distributed.Process hiding (monitor) +import Control.Distributed.Process.Node +import Control.Distributed.Process.Execution.EventManager hiding (start) +import qualified Control.Distributed.Process.Extras +import Control.Distributed.Process.Execution.Exchange +import Control.Distributed.Process.Extras.Internal.Types +import Control.Distributed.Process.Extras.Internal.Primitives +import qualified Control.Distributed.Process.Execution.EventManager as EventManager + ( start + ) +import Control.Distributed.Process.SysTest.Utils +import Control.Monad (void, forM, forever) +import Control.Rematch (equalTo) + +import Prelude hiding (drop) +import Network.Transport.TCP +import qualified Network.Transport as NT +import Test.Framework as TF (defaultMain, testGroup, Test) +import Test.Framework.Providers.HUnit + +testKeyBasedRouting :: TestResult Bool -> Process () +testKeyBasedRouting result = do + (sp, rp) <- newChan :: Process (Channel Int) + rex <- messageKeyRouter PayloadOnly + + -- Since the /router/ doesn't offer a syncrhonous start + -- option, we use spawnSignalled to get the same effect, + -- making it more likely (though it's not guaranteed) that + -- the spawned process will be bound to the routing exchange + -- prior to our evaluating 'routeMessage' below. + void $ spawnSignalled (bindKey "foobar" rex) $ const $ do + receiveWait [ match (\(s :: Int) -> sendChan sp s) ] + + routeMessage rex (createMessage "foobar" [] (123 :: Int)) + stash result . (== (123 :: Int)) =<< receiveChan rp + +testMultipleRoutes :: TestResult () -> Process () +testMultipleRoutes result = do + stash result () -- we don't rely on the test result for assertions... + (sp, rp) <- newChan + rex <- messageKeyRouter PayloadOnly + let recv = receiveWait [ + match (\(s :: String) -> getSelfPid >>= \us -> sendChan sp (us, Left s)) + , match (\(i :: Int) -> getSelfPid >>= \us -> sendChan sp (us, Right i)) + ] + + us <- getSelfPid + p1 <- spawnSignalled (link us >> bindKey "abc" rex) (const $ forever recv) + p2 <- spawnSignalled (link us >> bindKey "def" rex) (const $ forever recv) + p3 <- spawnSignalled (link us >> bindKey "abc" rex) (const $ forever recv) + + -- publish 2 messages with the routing-key set to 'abc' + routeMessage rex (createMessage "abc" [] "Hello") + routeMessage rex (createMessage "abc" [] (123 :: Int)) + + -- route another message with the 'abc' value a header (should be ignored) + routeMessage rex (createMessage "" [("abc", "abc")] "Goodbye") + + received <- forM (replicate (2 * 3) us) (const $ receiveChanTimeout 1000 rp) + + -- all bindings for 'abc' fired correctly + received `shouldContain` Just (p1, Left "Hello") + received `shouldContain` Just (p3, Left "Hello") + received `shouldContain` Just (p1, Right (123 :: Int)) + received `shouldContain` Just (p3, Right (123 :: Int)) + + -- however the bindings for 'def' never fired + received `shouldContain` Nothing + received `shouldNotContain` Just (p2, Left "Hello") + received `shouldNotContain` Just (p2, Right (123 :: Int)) + + -- none of the bindings should have examined the headers! + received `shouldNotContain` Just (p1, Left "Goodbye") + received `shouldNotContain` Just (p2, Left "Goodbye") + received `shouldNotContain` Just (p3, Left "Goodbye") + +testHeaderBasedRouting :: TestResult () -> Process () +testHeaderBasedRouting result = do + stash result () -- we don't rely on the test result for assertions... + (sp, rp) <- newChan + rex <- headerContentRouter PayloadOnly "x-name" + let recv = const $ forever $ receiveWait [ + match (\(s :: String) -> getSelfPid >>= \us -> sendChan sp (us, Left s)) + , match (\(i :: Int) -> getSelfPid >>= \us -> sendChan sp (us, Right i)) + ] + + us <- getSelfPid + p1 <- spawnSignalled (link us >> bindHeader "x-name" "yellow" rex) recv + p2 <- spawnSignalled (link us >> bindHeader "x-name" "red" rex) recv + _ <- spawnSignalled (link us >> bindHeader "x-type" "fast" rex) recv + + -- publish 2 messages with the routing-key set to 'abc' + routeMessage rex (createMessage "" [("x-name", "yellow")] "Hello") + routeMessage rex (createMessage "" [("x-name", "yellow")] (123 :: Int)) + routeMessage rex (createMessage "" [("x-name", "red")] (456 :: Int)) + routeMessage rex (createMessage "" [("x-name", "red")] (789 :: Int)) + routeMessage rex (createMessage "" [("x-type", "fast")] "Goodbye") + + -- route another message with the 'abc' value a header (should be ignored) + routeMessage rex (createMessage "" [("abc", "abc")] "FooBar") + + received <- forM (replicate 5 us) (const $ receiveChanTimeout 1000 rp) + + -- all bindings fired correctly + received `shouldContain` Just (p1, Left "Hello") + received `shouldContain` Just (p1, Right (123 :: Int)) + received `shouldContain` Just (p2, Right (456 :: Int)) + received `shouldContain` Just (p2, Right (789 :: Int)) + received `shouldContain` Nothing + + -- simple check that no other bindings have fired + length received `shouldBe` equalTo (5 :: Int) + +testSimpleEventHandling :: TestResult Bool -> Process () +testSimpleEventHandling result = do + (sp, rp) <- newChan + (sigStart, recvStart) <- newChan + em <- EventManager.start + Just pid <- resolve em + void $ monitor pid + + -- Note that in our init (state) function, we write a "start signal" + -- here; Without a start signal, the message sent to the event manager + -- (via notify) would race with the addHandler registration. + pid' <- addHandler em (myHandler sp) (sendChan sigStart ()) + link pid' + + () <- receiveChan recvStart + + notify em ("hello", "event", "manager") -- cast message + r <- receiveTimeout 100000000 [ + matchChan rp return + , match (\(ProcessMonitorNotification _ _ _) -> die "ServerDied") + ] + case r of + Just ("hello", "event", "manager") -> stash result True + _ -> stash result False + +myHandler :: SendPort (String, String, String) + -> () + -> (String, String, String) + -> Process () +myHandler sp s m@(_, _, _) = sendChan sp m >> return s + +myRemoteTable :: RemoteTable +myRemoteTable = + Control.Distributed.Process.Extras.__remoteTable initRemoteTable + +tests :: NT.Transport -> IO [Test] +tests transport = do + localNode <- newLocalNode transport myRemoteTable + return [ + testGroup "Event Manager" + [ + testCase "Simple Event Handlers" + (delayedAssertion "Expected the handler to run" + localNode True testSimpleEventHandling) + ] + + , testGroup "Router" + [ + testCase "Direct Key Routing" + (delayedAssertion "Expected the sole matching route to run" + localNode True testKeyBasedRouting) + , testCase "Key Based Selective Routing" + (delayedAssertion "Expected only the matching routes to run" + localNode () testMultipleRoutes) + , testCase "Header Based Selective Routing" + (delayedAssertion "Expected only the matching routes to run" + localNode () testHeaderBasedRouting) + ] + ] + +main :: IO () +main = testMain $ tests + +-- | Given a @builder@ function, make and run a test suite on a single transport +testMain :: (NT.Transport -> IO [Test]) -> IO () +testMain builder = do + Right (transport, _) <- createTransportExposeInternals (defaultTCPAddr "127.0.0.1" "10501") defaultTCPParameters + testData <- builder transport + defaultMain testData diff --git a/packages/distributed-process-execution/tests/TestMailbox.hs b/packages/distributed-process-execution/tests/TestMailbox.hs new file mode 100644 index 00000000..e0d25989 --- /dev/null +++ b/packages/distributed-process-execution/tests/TestMailbox.hs @@ -0,0 +1,261 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +import Control.Distributed.Process +import Control.Distributed.Process.Node +import qualified Control.Distributed.Process.Extras (__remoteTable) +import Control.Distributed.Process.Execution.Mailbox +import Control.Distributed.Process.Extras.Time +import Control.Distributed.Process.Extras.Timer +import Control.Distributed.Process.SysTest.Utils + + +import Control.Rematch (equalTo) + +import Prelude hiding (drop) + +import Data.Maybe (catMaybes) + +import Test.Framework as TF (defaultMain, testGroup, Test) +import Test.Framework.Providers.HUnit + +import qualified MailboxTestFilters (__remoteTable) +import MailboxTestFilters (myFilter, intFilter) + +import Network.Transport.TCP +import qualified Network.Transport as NT + +-- TODO: This whole test suite would be much better off using QuickCheck. +-- The test-framework driver however, doesn't have the API support we'd need +-- to wire in our tests, so we'll have to write a compatibility layer. +-- That should probably go into (or beneath) the C.D.P.P.Test module. + +allBuffersShouldRespectFIFOOrdering :: BufferType -> TestResult Bool -> Process () +allBuffersShouldRespectFIFOOrdering buffT result = do + let [a, b, c] = ["a", "b", "c"] + mbox <- createAndSend buffT [a, b, c] + active mbox acceptEverything + Just Delivery { messages = msgs } <- receiveTimeout (after 2 Seconds) + [ match return ] + let [ma', mb', mc'] = msgs + Just a' <- unwrapMessage ma' :: Process (Maybe String) + Just b' <- unwrapMessage mb' :: Process (Maybe String) + Just c' <- unwrapMessage mc' :: Process (Maybe String) + let values = [a', b', c'] + stash result $ values == [a, b, c] +-- if values /= [a, b, c] +-- then liftIO $ putStrLn $ "unexpected " ++ ((show buffT) ++ (" values: " ++ (show values))) +-- else return () + +resizeShouldRespectOrdering :: BufferType + -> TestResult [String] + -> Process () +resizeShouldRespectOrdering buffT result = do + let [a, b, c, d, e] = ["a", "b", "c", "d", "e"] + mbox <- createAndSend buffT [a, b, c, d, e] + resize mbox (3 :: Integer) + + active mbox acceptEverything + Just Delivery{ messages = msgs } <- receiveTimeout (after 2 Seconds) [ match return ] + + let [mc', md', me'] = msgs + Just c' <- unwrapMessage mc' :: Process (Maybe String) + Just d' <- unwrapMessage md' :: Process (Maybe String) + Just e' <- unwrapMessage me' :: Process (Maybe String) + let values = [c', d', e'] + stash result $ values + +bufferLimiting :: BufferType -> TestResult (Integer, [Maybe String]) -> Process () +bufferLimiting buffT result = do + let msgs = ["a", "b", "c", "d", "e", "f", "g"] + mbox <- createMailboxAndPost buffT 4 msgs + + MailboxStats{ pendingMessages = pending' + , droppedMessages = dropped' + , currentLimit = limit' } <- statistics mbox + pending' `shouldBe` equalTo 4 + dropped' `shouldBe` equalTo 3 + limit' `shouldBe` equalTo 4 + + active mbox acceptEverything + Just Delivery{ messages = recvd + , totalDropped = skipped } <- receiveTimeout (after 5 Seconds) + [ match return ] + seen <- mapM unwrapMessage recvd + stash result (skipped, seen) + +mailboxIsInitiallyPassive :: TestResult Bool -> Process () +mailboxIsInitiallyPassive result = do + mbox <- createMailbox Stack (6 :: Integer) + mapM_ (post mbox) ([1..5] :: [Int]) + Nothing <- receiveTimeout (after 3 Seconds) [ matchAny return ] + notify mbox + inbound <- receiveTimeout (after 3 Seconds) [ match return ] + case inbound of + Just (NewMail _ _) -> stash result True + Nothing -> stash result False + +complexMailboxFiltering :: (String, Int, Bool) + -> TestResult (String, Int, Bool) + -> Process () +complexMailboxFiltering inputs@(s', i', b') result = do + mbox <- createMailbox Stack (10 :: Integer) + post mbox s' + post mbox i' + post mbox b' + waitForMailboxReady mbox 3 + + active mbox $ myFilter inputs + Just Delivery{ messages = [m1, m2, m3] + , totalDropped = _ } <- receiveTimeout (after 5 Seconds) + [ match return ] + Just s <- unwrapMessage m1 :: Process (Maybe String) + Just i <- unwrapMessage m2 :: Process (Maybe Int) + Just b <- unwrapMessage m3 :: Process (Maybe Bool) + stash result $ (s, i, b) + +dropDuringFiltering :: TestResult Bool -> Process () +dropDuringFiltering result = do + let rng = [1..50] :: [Int] + mbox <- createMailbox Stack (50 :: Integer) + mapM_ (post mbox) rng + + waitForMailboxReady mbox 50 + active mbox $ intFilter + + Just Delivery{ messages = msgs } <- receiveTimeout (after 5 Seconds) + [ match return ] + seen <- mapM unwrapMessage msgs + stash result $ (catMaybes seen) == (filter even rng) + +mailboxHandleReUse :: TestResult Bool -> Process () +mailboxHandleReUse result = do + mbox <- createMailbox Queue (1 :: Limit) + post mbox "abc" + + notify mbox + Just (NewMail mbox' _) <- receiveTimeout (after 2 Seconds) + [ match return ] + deliver mbox' + _ <- expect :: Process Delivery + stash result True + +createAndSend :: BufferType -> [String] -> Process Mailbox +createAndSend buffT msgs = createMailboxAndPost buffT 10 msgs + +createMailboxAndPost :: BufferType -> Limit -> [String] -> Process Mailbox +createMailboxAndPost buffT maxSz msgs = do + (cc, cp) <- newChan + mbox <- createMailbox buffT maxSz + spawnLocal $ mapM_ (post mbox) msgs >> sendChan cc () + () <- receiveChan cp + waitForMailboxReady mbox $ min (toInteger (length msgs)) maxSz + return mbox + +waitForMailboxReady :: Mailbox -> Integer -> Process () +waitForMailboxReady mbox sz = do + sleep $ seconds 1 + notify mbox + m <- receiveWait [ + matchIf (\(NewMail mbox' sz') -> mbox == mbox' && sz' >= sz) + (\_ -> return True) + , match (\(NewMail _ _) -> return False) + , matchAny (\_ -> return False) + ] + case m of + True -> return () + False -> waitForMailboxReady mbox sz + +myRemoteTable :: RemoteTable +myRemoteTable = + Control.Distributed.Process.Execution.Mailbox.__remoteTable $ + Control.Distributed.Process.Extras.__remoteTable $ + MailboxTestFilters.__remoteTable initRemoteTable + +tests :: NT.Transport -> IO [Test] +tests transport = do + {- verboseCheckWithResult stdArgs -} + localNode <- newLocalNode transport myRemoteTable + return [ + testGroup "Dequeue/Pop Ordering" + [ + testCase "Queue Ordering" + (delayedAssertion + "Expected the Queue to offer FIFO ordering" + localNode True (allBuffersShouldRespectFIFOOrdering Queue)) + + , testCase "Stack Ordering" + (delayedAssertion + "Expected the Queue to offer FIFO ordering" + localNode True (allBuffersShouldRespectFIFOOrdering Stack)) + , testCase "Ring Ordering" + (delayedAssertion + "Expected the Queue to offer FIFO ordering" + localNode True (allBuffersShouldRespectFIFOOrdering Ring)) + ] + , testGroup "Resize & Ordering" + [ + testCase "Queue Drops Eldest" + (delayedAssertion + "expected c, d, e" + localNode ["c", "d", "e"] $ resizeShouldRespectOrdering Queue) + , testCase "Stack Drops Youngest" + (delayedAssertion + "expected a, b, c" + localNode ["a", "b", "c"] $ resizeShouldRespectOrdering Stack) + , testCase "Ring Drops Youngest" + (delayedAssertion + "expected a, b, c" + localNode ["a", "b", "c"] $ resizeShouldRespectOrdering Ring) + ] + , testGroup "Buffer Limits & Discarded Messages" + [ + testCase "Queue Drops Eldest and Enqueues New" + (delayedAssertion + "expected d, e, f, g" + localNode ((3 :: Integer), map Just ["d", "e", "f", "g"]) $ bufferLimiting Queue) + , testCase "Stack Drops Youngest And Pushes New" + (delayedAssertion + "expected a, b, c, g" + localNode ((3 :: Integer), map Just ["a", "b", "c", "g"]) $ bufferLimiting Stack) + , testCase "Ring Rejects New Entries" + (delayedAssertion + "expected a, b, c, d" + localNode ((3 :: Integer), map Just ["a", "b", "c", "d"]) $ bufferLimiting Ring) + ] + , testGroup "Notification, Activation and Delivery" + [ + testCase "Mailbox is initially Passive" + (delayedAssertion + "Expected the Mailbox to remain passive until told otherwise" + localNode True mailboxIsInitiallyPassive) + , testCase "Mailbox Notifications include usable control channel" + (delayedAssertion + "Expected traffic to be relayed directly to us" + localNode True mailboxHandleReUse) + , testCase "Complex Filtering Rules" + (delayedAssertion + "Expected the relevant filters to accept our data" + localNode inputs (complexMailboxFiltering inputs)) + , testCase "Filter out unwanted messages" + (delayedAssertion + "Expected only even numbers to be sent delivered" + localNode True dropDuringFiltering) + ] + ] + where + inputs = ("hello", 10 :: Int, True) + +main :: IO () +main = testMain $ tests + +-- | Given a @builder@ function, make and run a test suite on a single transport +testMain :: (NT.Transport -> IO [Test]) -> IO () +testMain builder = do + Right (transport, _) <- createTransportExposeInternals (defaultTCPAddr "127.0.0.1" "10501") defaultTCPParameters + testData <- builder transport + defaultMain testData diff --git a/packages/distributed-process-extras/ChangeLog b/packages/distributed-process-extras/ChangeLog new file mode 100644 index 00000000..d00120e4 --- /dev/null +++ b/packages/distributed-process-extras/ChangeLog @@ -0,0 +1,30 @@ +2017-06-13 Alexander Vershilov 0.3.5 +* Bump dependencies +* Cleanup code + +2017-02-05 Tim Watson 0.3.0 + +* re-implement whereIsRemote in terms of whereIsRemoteAsync +* re-implement whereisOrStart to avoid leaking zombie processes +* implement general NFSerializable instances +* make Resolvable instance of (NodeId, String) exception safe +* remove dependency on data-accessor +* Relax upper bound on time for testing +* documentation fixes and improvements + +2017-02-05 Tim Watson 0.3.0 + +* Update dependency bounds - drop support for distributed-process < 0.6.6 +* Drop support for GHC < 7.10 +* Fixes for testing with latest stack and CI changes + +2016-02-16 Facundo Domínguez 0.2.1.2 + +* Update dependency bounds. + +2015-06-15 Facundo Domínguez 0.2.1 + +* Use random port in tests. +* Add compatibility with ghc-7.10. +* Fix dependency bounds. +* Add missing NFData instances. diff --git a/packages/distributed-process-extras/LICENCE b/packages/distributed-process-extras/LICENCE new file mode 100644 index 00000000..f7a8c56f --- /dev/null +++ b/packages/distributed-process-extras/LICENCE @@ -0,0 +1,30 @@ +Copyright Tim Watson, 2012-2013. + +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. diff --git a/packages/distributed-process-extras/NOTES b/packages/distributed-process-extras/NOTES new file mode 100644 index 00000000..7839de4e --- /dev/null +++ b/packages/distributed-process-extras/NOTES @@ -0,0 +1,22 @@ +MAJOR TODOs (in no particular order) + +- implement Observable for Mailbox +- implement PCopy / pcopy :: PCopy a -> Process () and precv :: Process (Maybe (PCopy a)) +- provide InputChannel for PCopy data, i.e.: + +data InputChannel a = ReadChan (ReceivePort a) | ReadSTM (STM a) + +read (ReadChan rp) = expectChan rp +read (ReadSTM stm) = liftIO $ atomically stm + +offer + +- implement RoundRobinRouter, ContentBasedRouter +- finish off ResourcePool +- double check we're using NFSerializable where possible/necessary + +- implement LocalRegistry (?) +- possibly rationalise Registry with LocalRegistry (?) +- Health checks for services +- Service Monitoring + diff --git a/packages/distributed-process-extras/coverage.sh b/packages/distributed-process-extras/coverage.sh new file mode 100755 index 00000000..8cd5fd8d --- /dev/null +++ b/packages/distributed-process-extras/coverage.sh @@ -0,0 +1,4 @@ +#! /bin/sh + +travis_retry curl -L https://github.com/rubik/stack-hpc-coveralls/releases/download/v0.0.4.0/shc-linux-x64-$GHCVER.tar.bz2 | tar -xj +shc -- --hpc-dir=$(stack $ARGS path --local-install-root)`/hpc/combined --dont-send combined all diff --git a/packages/distributed-process-extras/distributed-process-extras.cabal b/packages/distributed-process-extras/distributed-process-extras.cabal new file mode 100644 index 00000000..93fb8793 --- /dev/null +++ b/packages/distributed-process-extras/distributed-process-extras.cabal @@ -0,0 +1,174 @@ +cabal-version: 3.0 +name: distributed-process-extras +version: 0.3.5 +build-type: Simple +license: BSD-3-Clause +license-file: LICENCE +stability: experimental +Copyright: Tim Watson 2012 - 2017 +Author: Tim Watson +maintainer: The Distributed Haskell team +Homepage: http://github.com/haskell-distributed/distributed-process-extras +Bug-Reports: http://github.com/haskell-distributed/distributed-process-extras/issues +synopsis: Cloud Haskell Extras +description: Supporting library, providing common types and utilities used by the + various libraries built on top of distributed-process +category: Control +tested-with: GHC==8.10.7 GHC==9.0.2 GHC==9.2.8 GHC==9.4.5 GHC==9.6.4 GHC==9.8.2 GHC==9.10.1 +extra-source-files: ChangeLog + +source-repository head + type: git + location: https://github.com/haskell-distributed/distributed-process-extras + +common warnings + ghc-options: -Wall + -Wcompat + -Widentities + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wredundant-constraints + -fhide-source-paths + -Wpartial-fields + +library + import: warnings + build-depends: base >= 4.14 && < 5, + distributed-process >= 0.6.0 && < 0.8, + binary >= 0.8 && < 0.9, + deepseq >= 1.4 && < 1.6, + mtl >= 2.0 && < 2.4, + containers >= 0.6 && < 0.8, + exceptions >= 0.10, + hashable >= 1.2.0.5 && < 1.6, + unordered-containers >= 0.2.3.0 && < 0.3, + fingertree < 0.2, + stm >= 2.4 && < 2.6, + transformers >= 0.2 && < 0.7, + time >= 1.5 + other-extensions: ExistentialQuantification + HS-Source-Dirs: src + exposed-modules: + Control.Distributed.Process.Extras + Control.Distributed.Process.Extras.Call + Control.Distributed.Process.Extras.Monitoring + Control.Distributed.Process.Extras.SystemLog + Control.Distributed.Process.Extras.Time + Control.Distributed.Process.Extras.Timer + Control.Distributed.Process.Extras.UnsafePrimitives + Control.Concurrent.Utils + Control.Distributed.Process.Extras.Internal.Containers.MultiMap + Control.Distributed.Process.Extras.Internal.Primitives + Control.Distributed.Process.Extras.Internal.Types + Control.Distributed.Process.Extras.Internal.Queue.SeqQ + Control.Distributed.Process.Extras.Internal.Queue.PriorityQ + Control.Distributed.Process.Extras.Internal.Unsafe + +test-suite InternalQueueTests + import: warnings + type: exitcode-stdio-1.0 + x-uses-tf: true + build-depends: + base >= 4.14 && < 5, + ansi-terminal >= 0.5 && < 0.9, + distributed-process >= 0.6.0 && < 0.8, + distributed-process-extras, + distributed-process-systest >= 0.1.0 && < 0.4, + HUnit >= 1.2 && < 2, + test-framework >= 0.6 && < 0.9, + test-framework-hunit, + QuickCheck >= 2.4, + test-framework-quickcheck2, + rematch >= 0.2.0.0, + ghc-prim + hs-source-dirs: tests + ghc-options: -rtsopts + main-is: TestQueues.hs + cpp-options: -DTESTING + +test-suite PrimitivesTests + import: warnings + type: exitcode-stdio-1.0 + x-uses-tf: true + build-depends: + base >= 4.14 && < 5, + ansi-terminal >= 0.5 && < 0.9, + distributed-process >= 0.6.0 && < 0.8, + distributed-process-extras, + distributed-process-systest >= 0.1.0 && < 0.4, + network-transport >= 0.4 && < 0.6, + mtl, + containers, + network-transport-tcp >= 0.4 && < 0.9, + binary >= 0.8 && < 0.9, + deepseq, + network >= 2.3 && < 3.3, + HUnit >= 1.2 && < 2, + stm, + test-framework >= 0.6 && < 0.9, + test-framework-hunit, + rematch >= 0.2.0.0, + transformers + hs-source-dirs: tests + ghc-options: -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind + main-is: TestPrimitives.hs + +test-suite TimerTests + import: warnings + type: exitcode-stdio-1.0 + x-uses-tf: true + build-depends: + base >= 4.14 && < 5, + ansi-terminal >= 0.5 && < 0.9, + deepseq, + distributed-process >= 0.6.0 && < 0.8, + distributed-process-extras, + distributed-process-systest >= 0.1.0 && < 0.4, + network-transport >= 0.4 && < 0.6, + network-transport-tcp >= 0.4 && < 0.9, + HUnit >= 1.2 && < 2, + test-framework >= 0.6 && < 0.9, + test-framework-hunit, + QuickCheck >= 2.4, + test-framework-quickcheck2, + rematch >= 0.2.0.0, + ghc-prim + hs-source-dirs: tests + ghc-options: -rtsopts + main-is: TestTimer.hs + cpp-options: -DTESTING + +test-suite LoggerTests + import: warnings + type: exitcode-stdio-1.0 +-- x-uses-tf: true + build-depends: + base >= 4.14 && < 5, + ansi-terminal >= 0.5 && < 0.9, + containers, + hashable, + unordered-containers >= 0.2.3.0 && < 0.3, + distributed-process >= 0.6.0 && < 0.8, + distributed-process-extras, + distributed-process-systest >= 0.1.0 && < 0.4, + distributed-static, + bytestring, + data-accessor, + fingertree < 0.2, + network-transport >= 0.4 && < 0.6, + deepseq, + mtl, + network-transport-tcp >= 0.4 && < 0.9, + binary >= 0.8 && < 0.9, + network >= 2.3 && < 3.3, + HUnit >= 1.2 && < 2, + stm, + time > 1.4 && < 1.15, + test-framework >= 0.6 && < 0.9, + test-framework-hunit, + transformers, + rematch >= 0.2.0.0, + ghc-prim + hs-source-dirs: tests + ghc-options: -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind + main-is: TestLog.hs diff --git a/packages/distributed-process-extras/src/Control/Concurrent/Utils.hs b/packages/distributed-process-extras/src/Control/Concurrent/Utils.hs new file mode 100644 index 00000000..a8162411 --- /dev/null +++ b/packages/distributed-process-extras/src/Control/Concurrent/Utils.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE ExistentialQuantification #-} +module Control.Concurrent.Utils + ( Lock() + , mkExclusiveLock + , mkQLock + , withLock + ) where + +import Control.Monad.Catch (MonadMask) +import qualified Control.Monad.Catch as Catch +import Control.Concurrent.MVar + ( newMVar + , takeMVar + , putMVar + ) +import Control.Concurrent.QSem +import Control.Monad.IO.Class (MonadIO, liftIO) + +-- | Opaque lock. +data Lock = forall l . Lock l (l -> IO ()) (l -> IO ()) + +-- | Take a lock. +acquire :: MonadIO m => Lock -> m () +acquire (Lock l acq _) = liftIO $ acq l + +-- | Release lock. +release :: MonadIO m => Lock -> m () +release (Lock l _ rel) = liftIO $ rel l + +-- | Create exclusive lock. Only one process could take such lock. +mkExclusiveLock :: IO Lock +mkExclusiveLock = Lock <$> newMVar () <*> pure takeMVar <*> pure (flip putMVar ()) + +-- | Create quantity lock. A fixed number of processes can take this lock simultaniously. +mkQLock :: Int -> IO Lock +mkQLock n = Lock <$> newQSem n <*> pure waitQSem <*> pure signalQSem + +-- | Run action under a held lock. +withLock :: (MonadMask m, MonadIO m) => Lock -> m a -> m a +withLock excl = + Catch.bracket_ (acquire excl) + (release excl) diff --git a/packages/distributed-process-extras/src/Control/Distributed/Process/Extras.hs b/packages/distributed-process-extras/src/Control/Distributed/Process/Extras.hs new file mode 100644 index 00000000..16ae71d8 --- /dev/null +++ b/packages/distributed-process-extras/src/Control/Distributed/Process/Extras.hs @@ -0,0 +1,126 @@ +{- | [Cloud Haskell Extras] + +[Evaluation Strategies and Support for NFData] + +When sending messages to a local process (i.e., intra-node), the default +approach is to encode (i.e., serialise) the message /anyway/, just to +ensure that no unevaluated thunks are passed to the receiver. +In distributed-process, you must explicitly choose to use /unsafe/ primitives +that do nothing to ensure evaluation, since this might cause an error in the +receiver which would be difficult to debug. Using @NFData@, it is possible +to force evaluation, but there is no way to ensure that both the @NFData@ +and @Binary@ instances do so in the same way (i.e., to the same depth, etc) +therefore automatic use of @NFData@ is not possible in distributed-process. + +By contrast, distributed-process-platform makes extensive use of @NFData@ +to force evaluation (and avoid serialisation overheads during intra-node +communication), via the @NFSerializable@ type class. This does nothing to +fix the potential disparity between @NFData@ and @Binary@ instances, so you +should verify that your data is being handled as expected (e.g., by sticking +to strict fields, or some such) and bear in mind that things could go wrong. + +The @UnsafePrimitives@ module in /this/ library will force evaluation before +calling the @UnsafePrimitives@ in distributed-process, which - if you've +vetted everything correctly - should provide a bit more safety, whilst still +keeping performance at an acceptable level. + +Users of the various service and utility models (such as @ManagedProcess@ and +the @Service@ and @Task@ APIs) should consult the sub-system specific +documentation for instructions on how to utilise these features. + +IMPORTANT NOTICE: Despite the apparent safety of forcing evaluation before +sending, we /still/ cannot make any actual guarantees about the evaluation +semantics of these operations, and therefore the /unsafe/ moniker will remain +in place, in one form or another, for all functions and modules that use them. + +[Addressing/Interaction Tools] + +The various type classes exposed here, along with some common data types (such +as @Shutdown@, @ServerDisconnected@, etc.) are intended to simplify your CH +programs, and facilitate easily plugging code into higher level libraries such +as distributed-process-client-server and distributed-process-supervisor. + +[Error/Exception Handling] + +It is /important/ not to be too general when catching exceptions in +cloud haskell application, because asynchonous exceptions provide cloud haskell +with its process termination mechanism. Two exception types in particular, +signal the instigator's intention to stop a process immediately, which are +raised (i.e., thrown) in response to the @kill@ and @exit@ primitives provided +by the base distributed-process package. + +You should generally try to keep exception handling code to the lowest (i.e., +most specific) scope possible. If you wish to trap @exit@ signals, use the +various flavours of @catchExit@ primitive from distributed-process. + +-} +module Control.Distributed.Process.Extras + ( + -- * Exported Types + Addressable + , Resolvable(..) + , Routable(..) + , Linkable(..) + , Killable(..) + , Monitored(..) + , NFSerializable + , Recipient(..) + , Shutdown(..) + , ExitReason(..) + , CancelWait(..) + , ServerDisconnected(..) + , Channel + , Tag + , TagPool + + -- * Primitives overriding those in distributed-process + , monitor + , module Control.Distributed.Process.Extras.UnsafePrimitives + + -- * Utilities and Extended Primitives + , spawnSignalled + , spawnLinkLocal + , spawnMonitorLocal + , linkOnFailure + , times + , isProcessAlive + , matchCond + , deliver + , awaitExit + , awaitResponse + + -- * Call/Tagging support + , newTagPool + , getTag + + -- * Registration and Process Lookup + , whereisOrStart + , whereisOrStartRemote + + -- remote call table + , __remoteTable + ) where + +import Control.Distributed.Process (RemoteTable) +import Control.Distributed.Process.Extras.Internal.Types + ( NFSerializable + , Recipient(..) + , Shutdown(..) + , ExitReason(..) + , CancelWait(..) + , ServerDisconnected(..) + , Channel + , Tag + , TagPool + , newTagPool + , getTag + ) +import Control.Distributed.Process.Extras.UnsafePrimitives +import Control.Distributed.Process.Extras.Internal.Primitives hiding (__remoteTable) +import qualified Control.Distributed.Process.Extras.Internal.Primitives (__remoteTable) + +-- remote table + +__remoteTable :: RemoteTable -> RemoteTable +__remoteTable = + Control.Distributed.Process.Extras.Internal.Primitives.__remoteTable diff --git a/packages/distributed-process-extras/src/Control/Distributed/Process/Extras/Call.hs b/packages/distributed-process-extras/src/Control/Distributed/Process/Extras/Call.hs new file mode 100644 index 00000000..dd82bea8 --- /dev/null +++ b/packages/distributed-process-extras/src/Control/Distributed/Process/Extras/Call.hs @@ -0,0 +1,243 @@ +{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Distributed.Process.Extras.Call +-- Copyright : (c) Parallel Scientific (Jeff Epstein) 2012 +-- License : BSD3 (see the file LICENSE) +-- +-- Maintainers : Jeff Epstein, Tim Watson +-- Stability : experimental +-- Portability : non-portable (requires concurrency) +-- +-- This module provides a facility for Remote Procedure Call (rpc) style +-- interactions with Cloud Haskell processes. +-- +-- Clients make synchronous calls to a running process (i.e., server) using the +-- 'callAt', 'callTimeout' and 'multicall' functions. Processes acting as the +-- server are constructed using Cloud Haskell's 'receive' family of primitives +-- and the 'callResponse' family of functions in this module. +----------------------------------------------------------------------------- + +module Control.Distributed.Process.Extras.Call + ( -- client API + callAt + , callTimeout + , multicall + -- server API + , callResponse + , callResponseIf + , callResponseDefer + , callResponseDeferIf + , callForward + , callResponseAsync + ) where + +import Control.Distributed.Process +import Control.Distributed.Process.Serializable (Serializable) +import Control.Monad (forM, forM_, join) +import Data.List (delete) +import qualified Data.Map as M +import Data.Maybe (listToMaybe) +import Data.Binary (Binary,get,put) +import Data.Typeable (Typeable) + +import Control.Distributed.Process.Extras hiding (monitor, send) +import Control.Distributed.Process.Extras.Time + +---------------------------------------------- +-- * Multicall +---------------------------------------------- + +-- | Sends a message of type a to the given process, to be handled by a +-- corresponding callResponse... function, which will send back a message of +-- type b. The tag is per-process unique identifier of the transaction. If the +-- timeout expires or the target process dies, Nothing will be returned. +callTimeout :: (Serializable a, Serializable b) + => ProcessId -> a -> Tag -> Timeout -> Process (Maybe b) +callTimeout pid msg tag time = + do res <- multicall [pid] msg tag time + return $ join (listToMaybe res) + +-- | Like 'callTimeout', but with no timeout. +-- Returns Nothing if the target process dies. +callAt :: (Serializable a, Serializable b) + => ProcessId -> a -> Tag -> Process (Maybe b) +callAt pid msg tag = callTimeout pid msg tag infiniteWait + +-- | Like 'callTimeout', but sends the message to multiple +-- recipients and collects the results. +multicall :: forall a b.(Serializable a, Serializable b) + => [ProcessId] -> a -> Tag -> Timeout -> Process [Maybe b] +multicall nodes msg tag time = + do caller <- getSelfPid + receiver <- spawnLocal $ + do receiver_pid <- getSelfPid + mon_caller <- monitor caller + () <- expect + monitortags <- forM nodes monitor + forM_ nodes $ \node -> send node (Multicall, node, + receiver_pid, tag, msg) + maybeTimeout time tag receiver_pid + results <- recv nodes monitortags mon_caller + send caller (MulticallResponse,tag,results) + mon_receiver <- monitor receiver + send receiver () + receiveWait [ + matchIf (\(MulticallResponse,mtag,_) -> mtag == tag) + (\(MulticallResponse,_,val) -> return val), + matchIf (\(ProcessMonitorNotification ref _pid reason) + -> ref == mon_receiver && reason /= DiedNormal) + (\_ -> error "multicall: unexpected termination of worker") + ] + where + recv nodes' monitortags mon_caller = do + resultmap <- recv1 mon_caller + (nodes', monitortags, M.empty) :: Process (M.Map ProcessId b) + return $ ordered nodes' resultmap + + ordered [] _ = [] + ordered (x:xs) m = M.lookup x m : ordered xs m + + recv1 _ ([],_,results) = return results + recv1 _ (_,[],results) = return results + recv1 ref (nodesleft,monitortagsleft,results) = + receiveWait [ + matchIf (\(ProcessMonitorNotification ref' _ _) + -> ref' == ref) + (\_ -> return Nothing) + , matchIf (\(ProcessMonitorNotification ref' pid reason) -> + ref' `elem` monitortagsleft && + pid `elem` nodesleft + && reason /= DiedNormal) + (\(ProcessMonitorNotification ref' pid _reason) -> + return $ Just (delete pid nodesleft, + delete ref' monitortagsleft, results)) + , matchIf (\(MulticallResponse, mtag, _, _) -> mtag == tag) + (\(MulticallResponse, _, responder, msgx) -> + return $ Just (delete responder nodesleft, + monitortagsleft, + M.insert responder (msgx :: b) results)) + , matchIf (\(TimeoutNotification mtag) -> mtag == tag ) + (\_ -> return Nothing) + ] + >>= maybe (return results) (recv1 ref) + +data MulticallResponseType a = + MulticallAccept + | MulticallForward ProcessId a + | MulticallReject deriving Eq + +callResponseImpl :: (Serializable a,Serializable b) + => (a -> MulticallResponseType c) -> + (a -> (b -> Process())-> Process c) -> Match c +callResponseImpl cond proc = + matchIf (\(Multicall,_responder,_,_,msg) -> + case cond msg of + MulticallReject -> False + _ -> True) + (\wholemsg@(Multicall,responder,sender,tag,msg) -> + case cond msg of + -- TODO: sender should get a ProcessMonitorNotification if + -- our target dies, or we should link to it (?) + MulticallForward target ret -> send target wholemsg >> return ret + -- TODO: use `die Reason` when issue #110 is resolved + MulticallReject -> error "multicallResponseImpl: Indecisive condition" + MulticallAccept -> + let resultSender tosend = + send sender (MulticallResponse, + tag::Tag, + responder::ProcessId, + tosend) + in proc msg resultSender) + +-- | Produces a Match that can be used with the 'receiveWait' family of +-- message-receiving functions. @callResponse@ will respond to a message of +-- type a sent by 'callTimeout', and will respond with a value of type b. +callResponse :: (Serializable a,Serializable b) + => (a -> Process (b,c)) -> Match c +callResponse = callResponseIf (const True) + +callResponseDeferIf :: (Serializable a,Serializable b) + => (a -> Bool) + -> (a -> (b -> Process()) -> Process c) + -> Match c +callResponseDeferIf cond = + callResponseImpl (\msg -> + if cond msg + then MulticallAccept + else MulticallReject) + +callResponseDefer :: (Serializable a,Serializable b) + => (a -> (b -> Process())-> Process c) -> Match c +callResponseDefer = callResponseDeferIf (const True) + +-- | Produces a Match that can be used with the 'receiveWait' family of +-- message-receiving functions. When calllForward receives a message of type +-- from from 'callTimeout' (and similar), it will forward the message to another +-- process, who will be responsible for responding to it. It is the user's +-- responsibility to ensure that the forwarding process is linked to the +-- destination process, so that if it fails, the sender will be notified. +callForward :: Serializable a => (a -> (ProcessId, c)) -> Match c +callForward proc = + callResponseImpl + (\msg -> let (pid, ret) = proc msg + in MulticallForward pid ret ) + (\_ sender -> + (sender::(() -> Process ())) `mention` + error "multicallForward: Indecisive condition") + +-- | The message handling code is started in a separate thread. It's not +-- automatically linked to the calling thread, so if you want it to be +-- terminated when the message handling thread dies, you'll need to call +-- link yourself. +callResponseAsync :: (Serializable a,Serializable b) + => (a -> Maybe c) -> (a -> Process b) -> Match c +callResponseAsync cond proc = + callResponseImpl + (\msg -> + case cond msg of + Nothing -> MulticallReject + Just _ -> MulticallAccept) + (\msg sender -> + do _ <- spawnLocal $ -- TODO linkOnFailure to spawned procss + do val <- proc msg + sender val + case cond msg of + Nothing -> error "multicallResponseAsync: Indecisive condition" + Just ret -> return ret ) + +callResponseIf :: (Serializable a,Serializable b) + => (a -> Bool) -> (a -> Process (b,c)) -> Match c +callResponseIf cond proc = + callResponseImpl + (\msg -> + case cond msg of + True -> MulticallAccept + False -> MulticallReject) + (\msg sender -> + do (tosend,toreturn) <- proc msg + sender tosend + return toreturn) + +maybeTimeout :: Timeout -> Tag -> ProcessId -> Process () +maybeTimeout Nothing _ _ = return () +maybeTimeout (Just time) tag p = timeout time tag p + +---------------------------------------------- +-- * Private types +---------------------------------------------- + +mention :: a -> b -> b +mention _a b = b + +data Multicall = Multicall + deriving (Typeable) +instance Binary Multicall where + get = return Multicall + put _ = return () +data MulticallResponse = MulticallResponse + deriving (Typeable) +instance Binary MulticallResponse where + get = return MulticallResponse + put _ = return () diff --git a/packages/distributed-process-extras/src/Control/Distributed/Process/Extras/Internal/Containers.hs b/packages/distributed-process-extras/src/Control/Distributed/Process/Extras/Internal/Containers.hs new file mode 100644 index 00000000..98cad039 --- /dev/null +++ b/packages/distributed-process-extras/src/Control/Distributed/Process/Extras/Internal/Containers.hs @@ -0,0 +1,11 @@ +module Control.Distributed.Process.Extras.Internal.Containers where + +class (Eq k, Functor m) => Map m k | m -> k where + empty :: m a + member :: k -> m a -> Bool + insert :: k -> a -> m a -> m a + delete :: k -> m a -> m a + lookup :: k -> m a -> a + filter :: (a -> Bool) -> m a -> m a + filterWithKey :: (k -> a -> Bool) -> m a -> m a + diff --git a/packages/distributed-process-extras/src/Control/Distributed/Process/Extras/Internal/Containers/MultiMap.hs b/packages/distributed-process-extras/src/Control/Distributed/Process/Extras/Internal/Containers/MultiMap.hs new file mode 100644 index 00000000..b7b6032a --- /dev/null +++ b/packages/distributed-process-extras/src/Control/Distributed/Process/Extras/Internal/Containers/MultiMap.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TupleSections #-} + +module Control.Distributed.Process.Extras.Internal.Containers.MultiMap + ( MultiMap + , Insertable + , empty + , insert + , member + , lookup + , delete + , filter + , filterWithKey + , foldrWithKey + , toList + , size + ) where + +import qualified Data.Foldable as Foldable +import Data.Foldable (Foldable) + +import Data.Hashable +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as Map +import Data.HashSet (HashSet) +import qualified Data.HashSet as Set +import Data.Foldable (Foldable(foldr)) +import Prelude hiding (lookup, filter, pred) + +-- | Class of things that can be inserted in a map or +-- a set (of mapped values), for which instances of +-- @Eq@ and @Hashable@ must be present. +-- +class (Eq a, Hashable a) => Insertable a +instance (Eq a, Hashable a) => Insertable a + +-- | Opaque type of MultiMaps. +data MultiMap k v = M { hmap :: !(HashMap k (HashSet v)) } + +-- instance Foldable + +instance Foldable (MultiMap k) where + foldr f = foldrWithKey (const f) + +empty :: MultiMap k v +empty = M $ Map.empty + +size :: MultiMap k v -> Int +size = Map.size . hmap + +insert :: forall k v. (Insertable k, Insertable v) + => k -> v -> MultiMap k v -> MultiMap k v +insert k' v' M{..} = + case Map.lookup k' hmap of + Nothing -> M $ Map.insert k' (Set.singleton v') hmap + Just s -> M $ Map.insert k' (Set.insert v' s) hmap +{-# INLINE insert #-} + +member :: (Insertable k) => k -> MultiMap k a -> Bool +member k = Map.member k . hmap + +lookup :: (Insertable k) => k -> MultiMap k v -> Maybe [v] +lookup k M{..} = maybe Nothing (Just . Foldable.toList) $ Map.lookup k hmap +{-# INLINE lookup #-} + +delete :: (Insertable k) => k -> MultiMap k v -> Maybe ([v], MultiMap k v) +delete k m@M{..} = maybe Nothing (Just . (, M $ Map.delete k hmap)) $ lookup k m + +filter :: forall k v. (Insertable k) + => (v -> Bool) + -> MultiMap k v + -> MultiMap k v +filter p M{..} = M $ Map.foldlWithKey' (matchOn p) hmap hmap + where + matchOn pred acc key valueSet = + let vs = Set.filter pred valueSet in + if Set.null vs then acc else Map.insert key vs acc +{-# INLINE filter #-} + +filterWithKey :: forall k v. (Insertable k) + => (k -> v -> Bool) + -> MultiMap k v + -> MultiMap k v +filterWithKey p M{..} = M $ Map.foldlWithKey' (matchOn p) hmap hmap + where + matchOn pred acc key valueSet = + let vs = Set.filter (pred key) valueSet in + if Set.null vs then acc else Map.insert key vs acc +{-# INLINE filterWithKey #-} + +-- | /O(n)/ Reduce this map by applying a binary operator to all +-- elements, using the given starting value (typically the +-- right-identity of the operator). +foldrWithKey :: (k -> v -> a -> a) -> a -> MultiMap k v -> a +foldrWithKey f a M{..} = + let wrap = \k' v' acc' -> f k' v' acc' + in Map.foldrWithKey (\k v acc -> Set.foldr (wrap k) acc v) a hmap +{-# INLINE foldrWithKey #-} + +toList :: MultiMap k v -> [(k, v)] +toList M{..} = Map.foldlWithKey' explode [] hmap + where + explode xs k vs = Set.foldl' (\ys v -> ((k, v):ys)) xs vs +{-# INLINE toList #-} diff --git a/packages/distributed-process-extras/src/Control/Distributed/Process/Extras/Internal/IdentityPool.hs b/packages/distributed-process-extras/src/Control/Distributed/Process/Extras/Internal/IdentityPool.hs new file mode 100644 index 00000000..4d2ac19f --- /dev/null +++ b/packages/distributed-process-extras/src/Control/Distributed/Process/Extras/Internal/IdentityPool.hs @@ -0,0 +1,11 @@ +module Control.Distributed.Process.Extras.Internal.IdentityPool where + +-- import Control.Concurrent.STM (atomically) +-- import Control.Concurrent.STM.TChan (newTChanIO, readTChan, writeTChan) +import Control.Distributed.Process.Extras.Internal.Queue.PriorityQ (PriorityQ) +import qualified Control.Distributed.Process.Extras.Internal.Queue.PriorityQ as Queue + +data IdentityPool a = IDPool { reserved :: !a + , returns :: PriorityQ a a + } + diff --git a/packages/distributed-process-extras/src/Control/Distributed/Process/Extras/Internal/Primitives.hs b/packages/distributed-process-extras/src/Control/Distributed/Process/Extras/Internal/Primitives.hs new file mode 100644 index 00000000..f5d6123f --- /dev/null +++ b/packages/distributed-process-extras/src/Control/Distributed/Process/Extras/Internal/Primitives.hs @@ -0,0 +1,278 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Distributed.Process.Extras.Internal.Primitives +-- Copyright : (c) Tim Watson 2013 - 2017, Parallel Scientific (Jeff Epstein) 2012 +-- License : BSD3 (see the file LICENSE) +-- +-- Maintainers : Jeff Epstein, Tim Watson +-- Stability : experimental +-- Portability : non-portable (requires concurrency) +-- +-- This module provides a set of additional primitives that add functionality +-- to the basic Cloud Haskell APIs. +----------------------------------------------------------------------------- + +module Control.Distributed.Process.Extras.Internal.Primitives + ( -- * General Purpose Process Addressing + Addressable + , Routable(..) + , Resolvable(..) + , Linkable(..) + , Killable(..) + , Monitored(..) + + -- * Spawning and Linking + , spawnSignalled + , spawnLinkLocal + , spawnMonitorLocal + , linkOnFailure + + -- * Registered Processes + , whereisRemote + , whereisOrStart + , whereisOrStartRemote + + -- * Selective Receive/Matching + , matchCond + , awaitResponse + + -- * General Utilities + , times + , monitor + , awaitExit + , isProcessAlive + , forever' + , deliver + + -- * Remote Table + , __remoteTable + ) where + +import Control.Concurrent (myThreadId, throwTo) +import Control.Distributed.Process hiding (monitor, finally, catch) +import qualified Control.Distributed.Process as P (monitor, unmonitor) +import Control.Distributed.Process.Closure (seqCP, remotable, mkClosure) +import Control.Distributed.Process.Serializable (Serializable) +import Control.Distributed.Process.Extras.Internal.Types + ( Addressable + , Linkable(..) + , Killable(..) + , Resolvable(..) + , Routable(..) + , Monitored(..) + , RegisterSelf(..) + , ExitReason(ExitOther) + , whereisRemote + ) +import Control.Monad (void, (>=>), replicateM_) +import Control.Monad.Catch (finally, catchIf) +import Data.Maybe (isJust, fromJust) +import Data.Foldable (traverse_) + +-- utility + +-- | Monitor any @Resolvable@ object. +monitor :: Resolvable a => a -> Process (Maybe MonitorRef) +monitor = resolve >=> traverse P.monitor + +-- | Wait until @Resolvable@ object will exit. Return immediately +-- if object can't be resolved. +awaitExit :: Resolvable a => a -> Process () +awaitExit = resolve >=> traverse_ await where + await pid = withMonitorRef pid $ \ref -> receiveWait + [ matchIf (\(ProcessMonitorNotification r _ _) -> r == ref) + (\_ -> return ()) + ] + withMonitorRef pid = bracket (P.monitor pid) P.unmonitor + +-- | Send message to @Addressable@ object. +deliver :: (Addressable a, Serializable m) => m -> a -> Process () +deliver = flip sendTo + +-- | Check if specified process is alive. Information may be outdated. +isProcessAlive :: ProcessId -> Process Bool +isProcessAlive pid = isJust <$> getProcessInfo pid + +-- | Apply the supplied expression /n/ times +times :: Int -> Process () -> Process () +times = replicateM_ +{-# DEPRECATED times "use replicateM_ instead" #-} + +-- | Like 'Control.Monad.forever' but sans space leak +forever' :: Monad m => m a -> m b +forever' a = let a' = a >> a' in a' +{-# INLINE forever' #-} + +-- spawning, linking and generic server startup + +-- | Spawn a new (local) process. This variant takes an initialisation +-- action and a secondary expression from the result of the initialisation +-- to @Process ()@. The spawn operation synchronises on the completion of the +-- @before@ action, such that the calling process is guaranteed to only see +-- the newly spawned @ProcessId@ once the initialisation has successfully +-- completed. +spawnSignalled :: Process a -> (a -> Process ()) -> Process ProcessId +spawnSignalled before after = do + (sigStart, recvStart) <- newChan + (pid, mRef) <- spawnMonitorLocal $ do + initProc <- before + sendChan sigStart () + after initProc + receiveWait [ + matchIf (\(ProcessMonitorNotification ref _ _) -> ref == mRef) + (\(ProcessMonitorNotification _ _ dr) -> die $ ExitOther (show dr)) + , matchChan recvStart (\() -> return pid) + ] `finally` (unmonitor mRef) + +-- | Node local version of 'Control.Distributed.Process.spawnLink'. +-- Note that this is just the sequential composition of 'spawn' and 'link'. +-- (The "Unified" semantics that underlies Cloud Haskell does not even support +-- a synchronous link operation) +spawnLinkLocal :: Process () -> Process ProcessId +spawnLinkLocal p = do + pid <- spawnLocal p + link pid + return pid + +-- | Like 'spawnLinkLocal', but monitors the spawned process. +-- +spawnMonitorLocal :: Process () -> Process (ProcessId, MonitorRef) +spawnMonitorLocal p = do + pid <- spawnLocal p + ref <- P.monitor pid + return (pid, ref) + +-- | CH's 'link' primitive, unlike Erlang's, will trigger when the target +-- process dies for any reason. This function has semantics like Erlang's: +-- it will trigger 'ProcessLinkException' only when the target dies abnormally. +-- +linkOnFailure :: ProcessId -> Process () +linkOnFailure them = do + us <- getSelfPid + tid <- liftIO $ myThreadId + void $ spawnLocal $ do + callerRef <- P.monitor us + calleeRef <- P.monitor them + reason <- receiveWait [ + matchIf (\(ProcessMonitorNotification mRef _ _) -> + mRef == callerRef) -- nothing left to do + (\_ -> return DiedNormal) + , matchIf (\(ProcessMonitorNotification mRef' _ _) -> + mRef' == calleeRef) + (\(ProcessMonitorNotification _ _ r') -> return r') + ] + case reason of + DiedNormal -> return () + _ -> liftIO $ throwTo tid (ProcessLinkException us reason) + +-- | Returns the pid of the process that has been registered +-- under the given name. This refers to a local, per-node registration, +-- not @global@ registration. If that name is unregistered, a process +-- is started. This is a handy way to start per-node named servers. +-- +whereisOrStart :: String -> Process () -> Process ProcessId +whereisOrStart name proc = do + (sigStart, recvStart) <- newChan + (_, mRef) <- spawnMonitorLocal $ do + us <- getSelfPid + catchIf (\(ProcessRegistrationException _ r) -> isJust r) + (register name us >> sendChan sigStart us) + (\(ProcessRegistrationException _ rPid) -> + sendChan sigStart $ fromJust rPid) + proc + receiveWait [ + matchIf (\(ProcessMonitorNotification ref _ _) -> ref == mRef) + (\(ProcessMonitorNotification _ _ dr) -> die $ ExitOther (show dr)) + , matchChan recvStart return + ] `finally` (unmonitor mRef) + +-- | Helper function will register itself under a given name and send +-- result to given @Process@. +registerSelf :: (String, ProcessId) -> Process () +registerSelf (name,target) = + do self <- getSelfPid + register name self + send target (RegisterSelf, self) + () <- expect + return () + +$(remotable ['registerSelf]) + +-- | A remote equivalent of 'whereisOrStart'. It deals with the +-- node registry on the given node, and the process, if it needs to be started, +-- will run on that node. If the node is inaccessible, Nothing will be returned. +-- +whereisOrStartRemote :: NodeId -> String -> Closure (Process ()) -> Process (Maybe ProcessId) +whereisOrStartRemote nid name proc = + do mRef <- monitorNode nid + whereisRemoteAsync nid name + res <- receiveWait + [ matchIf (\(WhereIsReply label _) -> label == name) + (\(WhereIsReply _ mPid) -> return (Just mPid)), + matchIf (\(NodeMonitorNotification aref _ _) -> aref == mRef) + (\(NodeMonitorNotification _ _ _) -> return Nothing) + ] + case res of + Nothing -> return Nothing + Just (Just pid) -> unmonitor mRef >> return (Just pid) + Just Nothing -> + do self <- getSelfPid + sRef <- spawnAsync nid ($(mkClosure 'registerSelf) (name,self) `seqCP` proc) + ret <- receiveWait [ + matchIf (\(NodeMonitorNotification ref _ _) -> ref == mRef) + (\(NodeMonitorNotification _ _ _) -> return Nothing), + matchIf (\(DidSpawn ref _) -> ref==sRef ) + (\(DidSpawn _ pid) -> + do pRef <- P.monitor pid + receiveWait + [ matchIf (\(RegisterSelf, apid) -> apid == pid) + (\(RegisterSelf, _) -> do unmonitor pRef + send pid () + return $ Just pid), + matchIf (\(NodeMonitorNotification aref _ _) -> aref == mRef) + (\(NodeMonitorNotification _aref _ _) -> return Nothing), + matchIf (\(ProcessMonitorNotification ref _ _) -> ref==pRef) + (\(ProcessMonitorNotification _ _ _) -> return Nothing) + ] ) + ] + unmonitor mRef + case ret of + Nothing -> whereisOrStartRemote nid name proc + Just pid -> return $ Just pid + +-- advanced messaging/matching + +-- | An alternative to 'matchIf' that allows both predicate and action +-- to be expressed in one parameter. +matchCond :: (Serializable a) => (a -> Maybe (Process b)) -> Match b +matchCond cond = + let v n = (isJust n, fromJust n) + res = v . cond + in matchIf (fst . res) (snd . res) + +-- | Safe (i.e., monitored) waiting on an expected response/message. +awaitResponse :: Addressable a + => a + -> [Match (Either ExitReason b)] + -> Process (Either ExitReason b) +awaitResponse addr matches = do + mPid <- resolve addr + case mPid of + Nothing -> return $ Left $ ExitOther "UnresolvedAddress" + Just p -> + bracket (P.monitor p) + P.unmonitor + $ \mRef -> receiveWait ((matchRef mRef):matches) + where + matchRef :: MonitorRef -> Match (Either ExitReason b) + matchRef r = matchIf (\(ProcessMonitorNotification r' _ _) -> r == r') + (\(ProcessMonitorNotification _ _ d) -> do + return (Left (ExitOther (show d)))) diff --git a/packages/distributed-process-extras/src/Control/Distributed/Process/Extras/Internal/Queue/PriorityQ.hs b/packages/distributed-process-extras/src/Control/Distributed/Process/Extras/Internal/Queue/PriorityQ.hs new file mode 100644 index 00000000..1658e775 --- /dev/null +++ b/packages/distributed-process-extras/src/Control/Distributed/Process/Extras/Internal/Queue/PriorityQ.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE StandaloneDeriving #-} +module Control.Distributed.Process.Extras.Internal.Queue.PriorityQ where + +-- NB: we might try this with a skewed binomial heap at some point, +-- but for now, we'll use this module from the fingertree package +import qualified Data.PriorityQueue.FingerTree as PQ +import Data.PriorityQueue.FingerTree (PQueue) + +newtype PriorityQ k a = PriorityQ { q :: PQueue k a } + +{-# INLINE empty #-} +empty :: Ord k => PriorityQ k v +empty = PriorityQ $ PQ.empty + +{-# INLINE isEmpty #-} +isEmpty :: Ord k => PriorityQ k v -> Bool +isEmpty = PQ.null . q + +{-# INLINE singleton #-} +singleton :: Ord k => k -> a -> PriorityQ k a +singleton !k !v = PriorityQ $ PQ.singleton k v + +{-# INLINE enqueue #-} +enqueue :: Ord k => k -> v -> PriorityQ k v -> PriorityQ k v +enqueue !k !v p = PriorityQ (PQ.add k v $ q p) + +{-# INLINE dequeue #-} +dequeue :: Ord k => PriorityQ k v -> Maybe (v, PriorityQ k v) +dequeue p = maybe Nothing (\(v, pq') -> Just (v, pq')) $ + case (PQ.minView (q p)) of + Nothing -> Nothing + Just (v, q') -> Just (v, PriorityQ $ q') + +{-# INLINE peek #-} +peek :: Ord k => PriorityQ k v -> Maybe v +peek p = maybe Nothing (\(v, _) -> Just v) $ dequeue p diff --git a/packages/distributed-process-extras/src/Control/Distributed/Process/Extras/Internal/Queue/SeqQ.hs b/packages/distributed-process-extras/src/Control/Distributed/Process/Extras/Internal/Queue/SeqQ.hs new file mode 100644 index 00000000..139a0ef7 --- /dev/null +++ b/packages/distributed-process-extras/src/Control/Distributed/Process/Extras/Internal/Queue/SeqQ.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module Control.Distributed.Process.Extras.Internal.Queue.SeqQ + ( SeqQ + , empty + , isEmpty + , singleton + , enqueue + , dequeue + , peek + , filter + , size + ) + where + +-- A simple FIFO queue implementation backed by @Data.Sequence@. +import Prelude hiding (filter, length) +import Data.Sequence + ( Seq + , ViewR(..) + , (<|) + , viewr + , length + ) +import qualified Data.Sequence as Seq (empty, singleton, null, filter) + +newtype SeqQ a = SeqQ { q :: Seq a } + deriving (Show) + +instance Eq a => Eq (SeqQ a) where + a == b = (q a) == (q b) + +{-# INLINE empty #-} +empty :: SeqQ a +empty = SeqQ Seq.empty + +isEmpty :: SeqQ a -> Bool +isEmpty = Seq.null . q + +{-# INLINE singleton #-} +singleton :: a -> SeqQ a +singleton = SeqQ . Seq.singleton + +{-# INLINE enqueue #-} +enqueue :: SeqQ a -> a -> SeqQ a +enqueue s a = SeqQ $ a <| q s + +{-# INLINE dequeue #-} +dequeue :: SeqQ a -> Maybe (a, SeqQ a) +dequeue s = maybe Nothing (\(s' :> a) -> Just (a, SeqQ s')) $ getR s + +{-# INLINE peek #-} +peek :: SeqQ a -> Maybe a +peek s = maybe Nothing (\(_ :> a) -> Just a) $ getR s + +{-# INLINE size #-} +size :: SeqQ a -> Int +size = length . q + +filter :: (a -> Bool) -> SeqQ a -> SeqQ a +filter c s = SeqQ $ Seq.filter c (q s) + +getR :: SeqQ a -> Maybe (ViewR a) +getR s = + case (viewr (q s)) of + EmptyR -> Nothing + a -> Just a diff --git a/packages/distributed-process-extras/src/Control/Distributed/Process/Extras/Internal/Types.hs b/packages/distributed-process-extras/src/Control/Distributed/Process/Extras/Internal/Types.hs new file mode 100644 index 00000000..d2d3c109 --- /dev/null +++ b/packages/distributed-process-extras/src/Control/Distributed/Process/Extras/Internal/Types.hs @@ -0,0 +1,291 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FunctionalDependencies #-} + +-- | Types used throughout the Extras package +-- +module Control.Distributed.Process.Extras.Internal.Types + ( -- * Tagging + Tag + , TagPool + , newTagPool + , getTag + -- * Addressing + , Linkable(..) + , Killable(..) + , Resolvable(..) + , Routable(..) + , Monitored(..) + , Addressable + , Recipient(..) + , RegisterSelf(..) + -- * Interactions + , whereisRemote + , resolveOrDie + , CancelWait(..) + , Channel + , Shutdown(..) + , ExitReason(..) + , ServerDisconnected(..) + , NFSerializable + ) where + +import Control.Concurrent.MVar + ( MVar + , newMVar + , modifyMVar + ) +import Control.DeepSeq (NFData(..), ($!!)) +import Control.Distributed.Process hiding (send, catch) +import qualified Control.Distributed.Process as P + ( send + , unsafeSend + , unsafeNSend + ) +import Control.Distributed.Process.Serializable +import Control.Exception (SomeException) +import Control.Monad.Catch (catch) +import Data.Binary +import Data.Foldable (traverse_) +import Data.Maybe (fromJust) +import Data.Typeable (Typeable) +import GHC.Generics + +-------------------------------------------------------------------------------- +-- API -- +-------------------------------------------------------------------------------- + +-- | Introduces a class that brings NFData into scope along with Serializable, +-- such that we can force evaluation. Intended for use with the UnsafePrimitives +-- module (which wraps "Control.Distributed.Process.UnsafePrimitives"), and +-- guarantees evaluatedness in terms of @NFData@. Please note that we /cannot/ +-- guarantee that an @NFData@ instance will behave the same way as a @Binary@ +-- one with regards evaluation, so it is still possible to introduce unexpected +-- behaviour by using /unsafe/ primitives in this way. +-- +class (NFData a, Serializable a) => NFSerializable a +instance (NFData a, Serializable a) => NFSerializable a + +instance (NFSerializable a) => NFSerializable (SendPort a) + +-- | Tags provide uniqueness for messages, so that they can be +-- matched with their response. +type Tag = Int + +-- | Generates unique 'Tag' for messages and response pairs. +-- Each process that depends, directly or indirectly, on +-- the call mechanisms in "Control.Distributed.Process.Global.Call" +-- should have at most one TagPool on which to draw unique message +-- tags. +type TagPool = MVar Tag + +-- | Create a new per-process source of unique +-- message identifiers. +newTagPool :: Process TagPool +newTagPool = liftIO $ newMVar 0 + +-- | Extract a new identifier from a 'TagPool'. +getTag :: TagPool -> Process Tag +getTag tp = liftIO $ modifyMVar tp (\tag -> return (tag+1,tag)) + +-- | A synchronous version of 'whereis', this monitors the remote node +-- and returns @Nothing@ if the node goes down (since a remote node failing +-- or being non-contactible has the same effect as a process not being +-- registered from the caller's point of view). +whereisRemote :: NodeId -> String -> Process (Maybe ProcessId) +whereisRemote node name = do + mRef <- monitorNode node + whereisRemoteAsync node name + receiveWait [ matchIf (\(NodeMonitorNotification ref nid _) -> ref == mRef && + nid == node) + (\NodeMonitorNotification{} -> return Nothing) + , matchIf (\(WhereIsReply n _) -> n == name) + (\(WhereIsReply _ mPid) -> return mPid) + ] + +-- | Wait cancellation message. +data CancelWait = CancelWait + deriving (Eq, Show, Typeable, Generic) +instance Binary CancelWait where +instance NFData CancelWait where + +-- | Simple representation of a channel. +type Channel a = (SendPort a, ReceivePort a) + +-- | Used internally in whereisOrStart. Sent as (RegisterSelf,ProcessId). +data RegisterSelf = RegisterSelf + deriving (Typeable, Generic) +instance Binary RegisterSelf where +instance NFData RegisterSelf where + +-- | A ubiquitous /shutdown signal/ that can be used +-- to maintain a consistent shutdown/stop protocol for +-- any process that wishes to handle it. +data Shutdown = Shutdown + deriving (Typeable, Generic, Show, Eq) +instance Binary Shutdown where +instance NFData Shutdown where + +-- | Provides a /reason/ for process termination. +data ExitReason = + ExitNormal -- ^ indicates normal exit + | ExitShutdown -- ^ normal response to a 'Shutdown' + | ExitOther !String -- ^ abnormal (error) shutdown + deriving (Typeable, Generic, Eq, Show) +instance Binary ExitReason where +instance NFData ExitReason where + +baseAddressableErrorMessage :: (Resolvable a) => a -> String +baseAddressableErrorMessage _ = "CannotResolveAddressable" + +-- | Class of things to which a @Process@ can /link/ itself. +class Linkable a where + -- | Create a /link/ with the supplied object. + linkTo :: (Resolvable a) => a -> Process () + linkTo r = resolve r >>= traverse_ link + +class Monitored a r m | a r -> m where + mkMonitor :: a -> Process r + checkMonitor :: a -> r -> m -> Process Bool + +instance (Resolvable a) => Monitored a MonitorRef ProcessMonitorNotification where + mkMonitor a = monitor . fromJust =<< resolve a + checkMonitor p r (ProcessMonitorNotification ref pid _) = do + p' <- resolve p + case p' of + Nothing -> return False + Just pr -> return $ ref == r && pid == pr + +-- | Class of things that can be killed (or instructed to exit). +class Killable p where + -- | Kill (instruct to exit) generic process, using 'kill' primitive. + killProc :: Resolvable p => p -> String -> Process () + killProc r s = resolve r >>= traverse_ (flip kill $ s) + + -- | Kill (instruct to exit) generic process, using 'exit' primitive. + exitProc :: (Resolvable p, Serializable m) => p -> m -> Process () + exitProc r m = resolve r >>= traverse_ (flip exit $ m) + +instance Resolvable p => Killable p + +-- | resolve the Resolvable or die with specified msg plus details of what didn't resolve +resolveOrDie :: (Resolvable a) => a -> String -> Process ProcessId +resolveOrDie resolvable failureMsg = do + result <- resolve resolvable + case result of + Nothing -> die $ failureMsg ++ " " ++ unresolvableMessage resolvable + Just pid -> return pid + +-- | Class of things that can be resolved to a 'ProcessId'. +-- +class Resolvable a where + -- | Resolve the reference to a process id, or @Nothing@ if resolution fails + resolve :: a -> Process (Maybe ProcessId) + + -- | Unresolvable @Addressable@ Message + unresolvableMessage :: (Resolvable a) => a -> String + unresolvableMessage = baseAddressableErrorMessage + +instance Resolvable ProcessId where + resolve p = return (Just p) + unresolvableMessage p = "CannotResolvePid[" ++ (show p) ++ "]" + +instance Resolvable String where + resolve = whereis + unresolvableMessage s = "CannotResolveRegisteredName[" ++ s ++ "]" + +instance Resolvable (NodeId, String) where + resolve (nid, pname) = + whereisRemote nid pname `catch` (\(_ :: SomeException) -> return Nothing) + unresolvableMessage (n, s) = + "CannotResolveRemoteRegisteredName[name: " ++ s ++ ", node: " ++ (show n) ++ "]" + +-- Provide a unified API for addressing processes. + +-- | Class of things that you can route/send serializable message to +class Routable a where + + -- | Send a message to the target asynchronously + sendTo :: (Serializable m, Resolvable a) => a -> m -> Process () + sendTo a m = do + mPid <- resolve a + maybe (die (unresolvableMessage a)) + (\p -> P.send p m) + mPid + + -- | Send some @NFData@ message to the target asynchronously, + -- forcing evaluation (i.e., @deepseq@) beforehand. + unsafeSendTo :: (NFSerializable m, Resolvable a) => a -> m -> Process () + unsafeSendTo a m = do + mPid <- resolve a + maybe (die (unresolvableMessage a)) + (\p -> P.unsafeSend p $!! m) + mPid + +instance Routable ProcessId where + sendTo = P.send + unsafeSendTo pid msg = P.unsafeSend pid $!! msg + +instance Routable String where + sendTo = nsend + unsafeSendTo name msg = P.unsafeNSend name $!! msg + +instance Routable (NodeId, String) where + sendTo (nid, pname) = nsendRemote nid pname + unsafeSendTo = sendTo -- because serialisation *must* take place + +instance Routable (Message -> Process ()) where + sendTo f = f . wrapMessage + unsafeSendTo f = f . unsafeWrapMessage + +class (Resolvable a, Routable a) => Addressable a +instance Addressable ProcessId + +-- | A simple means of mapping to a receiver. +data Recipient = + Pid !ProcessId + | Registered !String + | RemoteRegistered !String !NodeId +-- | ProcReg !ProcessId !String +-- | RemoteProcReg NodeId String +-- | GlobalReg String + deriving (Typeable, Generic, Show, Eq) +instance Binary Recipient where +instance NFData Recipient where + rnf (Pid p) = rnf p `seq` () + rnf (Registered s) = rnf s `seq` () + rnf (RemoteRegistered s n) = rnf s `seq` rnf n `seq` () + +instance Resolvable Recipient where + resolve (Pid p) = return (Just p) + resolve (Registered n) = whereis n + resolve (RemoteRegistered s n) = whereisRemote n s + + unresolvableMessage (Pid p) = unresolvableMessage p + unresolvableMessage (Registered n) = unresolvableMessage n + unresolvableMessage (RemoteRegistered s n) = unresolvableMessage (n, s) + +-- although we have an instance of Routable for Resolvable, it really +-- makes no sense to do remote lookups on a pid, only to then send to it! +instance Routable Recipient where + + sendTo (Pid p) m = P.send p m + sendTo (Registered s) m = nsend s m + sendTo (RemoteRegistered s n) m = nsendRemote n s m + + unsafeSendTo (Pid p) m = P.unsafeSend p $!! m + unsafeSendTo (Registered s) m = P.unsafeNSend s $!! m + unsafeSendTo (RemoteRegistered s n) m = nsendRemote n s m + +-- useful exit reasons + +-- | Given when a server is unobtainable. +newtype ServerDisconnected = ServerDisconnected DiedReason + deriving (Typeable, Generic) +instance Binary ServerDisconnected where +instance NFData ServerDisconnected where diff --git a/packages/distributed-process-extras/src/Control/Distributed/Process/Extras/Internal/Unsafe.hs b/packages/distributed-process-extras/src/Control/Distributed/Process/Extras/Internal/Unsafe.hs new file mode 100644 index 00000000..9a466118 --- /dev/null +++ b/packages/distributed-process-extras/src/Control/Distributed/Process/Extras/Internal/Unsafe.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | If you don't know exactly what this module is for and precisely +-- how to use the types within, you should move on, quickly! +-- +-- [Implementation Notes] +-- This module provides facilities for forcibly sending non-serializable +-- data via cloud haskell's messaging primitives, such as @send@ et al. +-- Of course, if you attmept to do this when interacting with a remote process, +-- your application will break. +-- +-- NB: this module will be deprecated in the next dot release, pending rewrite +-- of the libraries that currently rely on it, to use the new supporting APIs +-- for STM interactions in distributed-process-client-server. +-- +module Control.Distributed.Process.Extras.Internal.Unsafe + ( -- * Copying non-serializable data + PCopy() + , pCopy + , matchP + , matchChanP + , pUnwrap + -- * Arbitrary (unmanaged) message streams + , InputStream(Null) + , newInputStream + , matchInputStream + , readInputStream + , InvalidBinaryShim(..) + ) where + +import Control.Concurrent.STM (STM, atomically) +import Control.Distributed.Process + ( matchAny + , matchChan + , matchSTM + , match + , handleMessage + , receiveChan + , liftIO + , die + , Match + , ReceivePort + , Message + , Process + ) +import Control.Distributed.Process.Serializable (Serializable) +import Data.Binary +import Control.DeepSeq (NFData) +import Data.Typeable (Typeable) +import GHC.Generics + +data InvalidBinaryShim = InvalidBinaryShim + deriving (Typeable, Show, Eq) + +-- NB: PCopy is a shim, allowing us to copy a pointer to otherwise +-- non-serializable data directly to another local process' +-- mailbox with no serialisation or even deepseq evaluation +-- required. We disallow remote queries (i.e., from other nodes) +-- and thus the Binary instance below is never used (though it's +-- required by the type system) and will in fact generate errors if +-- you attempt to use it at runtime. In other words, if you attempt +-- to make a @Message@ out of this, you'd better make sure you're +-- calling @unsafeCreateUnencodedMessage@, otherwise /BOOM/! You have +-- been warned. +-- +data PCopy a = PCopy !a + deriving (Typeable, Generic) +instance (NFData a) => NFData (PCopy a) where + +instance (Typeable a) => Binary (PCopy a) where + put _ = error "InvalidBinaryShim" + get = error "InvalidBinaryShim" + +-- | Wrap any @Typeable@ datum in a @PCopy@. We hide the constructor to +-- discourage arbitrary uses of the type, since @PCopy@ is a specialised +-- and potentially dangerous construct. +pCopy :: (Typeable a) => a -> PCopy a +pCopy = PCopy + +-- | Matches on @PCopy m@ and returns the /m/ within. +-- This potentially allows us to bypass serialization (and the type constraints +-- it enforces) for local message passing (i.e., with @UnencodedMessage@ data), +-- since PCopy is just a shim. +matchP :: (Typeable m) => Match (Maybe m) +matchP = matchAny pUnwrap + +-- | Given a raw @Message@, attempt to unwrap a @Typeable@ datum from +-- an enclosing @PCopy@ wrapper. +pUnwrap :: (Typeable m) => Message -> Process (Maybe m) +pUnwrap m = handleMessage m (\(PCopy m' :: PCopy m) -> return m') + +-- | Matches on a @TypedChannel (PCopy a)@. +matchChanP :: (Typeable m) => ReceivePort (PCopy m) -> Match m +matchChanP rp = matchChan rp (\(PCopy m' :: PCopy m) -> return m') + +-- | A generic input channel that can be read from in the same fashion +-- as a typed channel (i.e., @ReceivePort@). To read from an input stream +-- in isolation, see 'readInputStream'. To compose an 'InputStream' with +-- reads on a process' mailbox (and/or typed channels), see 'matchInputStream'. +-- +data InputStream a = ReadChan (ReceivePort a) | ReadSTM (STM a) | Null + deriving (Typeable) + +data NullInputStream = NullInputStream + deriving (Typeable, Generic, Show, Eq) +instance Binary NullInputStream where +instance NFData NullInputStream where + +-- [note: InputStream] +-- InputStream wraps either a ReceivePort or an arbitrary STM action. Used +-- internally when we want to allow internal clients to completely bypass +-- regular messaging primitives (which is rare but occaisionally useful), +-- the type (only, minus its constructors) is exposed to users of some +-- @Exchange@ APIs. + +-- | Create a new 'InputStream'. +newInputStream :: forall a. (Typeable a) + => Either (ReceivePort a) (STM a) + -> InputStream a +newInputStream (Left rp) = ReadChan rp +newInputStream (Right stm) = ReadSTM stm + +-- | Read from an 'InputStream'. This is a blocking operation. +readInputStream :: (Serializable a) => InputStream a -> Process a +readInputStream (ReadChan rp) = receiveChan rp +readInputStream (ReadSTM stm) = liftIO $ atomically stm +readInputStream Null = die $ NullInputStream + +-- | Constructs a @Match@ for a given 'InputChannel'. +matchInputStream :: InputStream a -> Match a +matchInputStream (ReadChan rp) = matchChan rp return +matchInputStream (ReadSTM stm) = matchSTM stm return +matchInputStream Null = match (\NullInputStream -> do + error "NullInputStream") diff --git a/packages/distributed-process-extras/src/Control/Distributed/Process/Extras/Monitoring.hs b/packages/distributed-process-extras/src/Control/Distributed/Process/Extras/Monitoring.hs new file mode 100644 index 00000000..c3026687 --- /dev/null +++ b/packages/distributed-process-extras/src/Control/Distributed/Process/Extras/Monitoring.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Distributed.Process.Extras.Monitoring +-- Copyright : (c) Tim Watson 2013 - 2017 +-- License : BSD3 (see the file LICENSE) +-- +-- Maintainer : Tim Watson +-- Stability : experimental +-- Portability : non-portable (requires concurrency) +-- +-- This module provides a primitive node monitoring capability, implemented as +-- a /distributed-process Management Agent/. Once the 'nodeMonitor' agent is +-- started, calling 'monitorNodes' will ensure that whenever the local node +-- detects a new network-transport connection (from another cloud haskell node), +-- the caller will receive a 'NodeUp' message in its mailbox. If a node +-- disconnects, a corollary 'NodeDown' message will be delivered as well. +-- +----------------------------------------------------------------------------- + +module Control.Distributed.Process.Extras.Monitoring + ( + NodeUp(..) + , NodeDown(..) + , nodeMonitorAgentId + , nodeMonitor + , monitorNodes + , unmonitorNodes + ) where + +import Control.DeepSeq (NFData) +import Control.Distributed.Process -- NB: requires NodeId(..) to be exported! +import Control.Distributed.Process.Management + ( MxEvent(MxConnected, MxDisconnected) + , MxAgentId(..) + , mxAgent + , mxSink + , mxReady + , liftMX + , mxGetLocal + , mxSetLocal + , mxNotify + ) +import Control.Distributed.Process.Extras (deliver) +import Data.Binary +import qualified Data.Foldable as Foldable +import Data.HashSet (HashSet) +import qualified Data.HashSet as Set + +import Data.Typeable (Typeable) +import GHC.Generics + +data Register = Register !ProcessId + deriving (Typeable, Generic) +instance Binary Register where +instance NFData Register where + +data UnRegister = UnRegister !ProcessId + deriving (Typeable, Generic) +instance Binary UnRegister where +instance NFData UnRegister where + +-- | Sent to subscribing processes when a connection +-- (from a remote node) is detected. +-- +data NodeUp = NodeUp !NodeId + deriving (Typeable, Generic, Show) +instance Binary NodeUp where +instance NFData NodeUp where + +-- | Sent to subscribing processes when a dis-connection +-- (from a remote node) is detected. +-- +data NodeDown = NodeDown !NodeId + deriving (Typeable, Generic, Show) +instance Binary NodeDown where +instance NFData NodeDown where + +-- | The @MxAgentId@ for the node monitoring agent. +nodeMonitorAgentId :: MxAgentId +nodeMonitorAgentId = MxAgentId "service.monitoring.nodes" + +-- | Start monitoring node connection/disconnection events. When a +-- connection event occurs, the calling process will receive a message +-- @NodeUp NodeId@ in its mailbox. When a disconnect occurs, the +-- corollary @NodeDown NodeId@ message will be delivered instead. +-- +-- No guaranatee is made about the timeliness of the delivery, nor can +-- the receiver expect that the node (for which it is being notified) +-- is still up/connected or down/disconnected at the point when it receives +-- a message from the node monitoring agent. +-- +monitorNodes :: Process () +monitorNodes = do + us <- getSelfPid + mxNotify $ Register us + +-- | Stop monitoring node connection/disconnection events. This does not +-- flush the caller's mailbox, nor does it guarantee that any/all node +-- up/down notifications will have been delivered before it is evaluated. +-- +unmonitorNodes :: Process () +unmonitorNodes = do + us <- getSelfPid + mxNotify $ UnRegister us + +-- | Starts the node monitoring agent. No call to @monitorNodes@ and +-- @unmonitorNodes@ will have any effect unless the agent is already +-- running. Note that we make /no guarantees what-so-ever/ about the +-- timeliness or ordering semantics of node monitoring notifications. +-- +nodeMonitor :: Process ProcessId +nodeMonitor = do + mxAgent nodeMonitorAgentId initState [ + (mxSink $ \(Register pid) -> do + mxSetLocal . Set.insert pid =<< mxGetLocal + mxReady) + , (mxSink $ \(UnRegister pid) -> do + mxSetLocal . Set.delete pid =<< mxGetLocal + mxReady) + , (mxSink $ \ev -> do + let act = + case ev of + (MxConnected _ ep) -> notify $ nodeUp ep + (MxDisconnected _ ep) -> notify $ nodeDown ep + _ -> return () + act >> mxReady) + ] + where + initState :: HashSet ProcessId + initState = Set.empty + + notify msg = Foldable.mapM_ (liftMX . deliver msg) =<< mxGetLocal + + nodeUp = NodeUp . NodeId + nodeDown = NodeDown . NodeId diff --git a/packages/distributed-process-extras/src/Control/Distributed/Process/Extras/SystemLog.hs b/packages/distributed-process-extras/src/Control/Distributed/Process/Extras/SystemLog.hs new file mode 100644 index 00000000..1c6d597b --- /dev/null +++ b/packages/distributed-process-extras/src/Control/Distributed/Process/Extras/SystemLog.hs @@ -0,0 +1,325 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ConstrainedClassMethods #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Distributed.Process.Extras.SystemLog +-- Copyright : (c) Tim Watson 2013 - 2017 +-- License : BSD3 (see the file LICENSE) +-- +-- Maintainer : Tim Watson +-- Stability : experimental +-- Portability : non-portable (requires concurrency) +-- +-- This module provides a general purpose logging facility, implemented as a +-- distributed-process /Management Agent/. To start the logging agent on a +-- running node, evaluate 'systemLog' with the relevant expressions to handle +-- logging textual messages, a cleanup operation (if required), initial log +-- level and a formatting expression. +-- +-- We export a working example in the form of 'systemLogFile', which logs +-- to a text file using buffered I/O. Its implementation is very simple, and +-- should serve as a demonstration of how to use the API: +-- +-- > systemLogFile :: FilePath -> LogLevel -> LogFormat -> Process ProcessId +-- > systemLogFile path lvl fmt = do +-- > h <- liftIO $ openFile path AppendMode +-- > liftIO $ hSetBuffering h LineBuffering +-- > systemLog (liftIO . hPutStrLn h) (liftIO (hClose h)) lvl fmt +-- +----------------------------------------------------------------------------- + +-- TODO - REWRITE THIS WITHOUT USING THE MX API, SINCE THAT's POINTLESS>>>>>>>. + +module Control.Distributed.Process.Extras.SystemLog + ( -- * Types exposed by this module + LogLevel(..) + , LogFormat + , LogClient + , LogChan + , LogText + , ToLog(..) + , Logger(..) + -- * Mx Agent Configuration / Startup + , mxLogId + , systemLog + , client + , logChannel + , addFormatter + -- * systemLogFile + , systemLogFile + -- * Logging Messages + , report + , debug + , info + , notice + , warning + , error + , critical + , alert + , emergency + , sendLog + ) where + +import Control.DeepSeq (NFData(..)) +import Control.Distributed.Process hiding (catch) +import Control.Distributed.Process.Management + ( MxEvent(MxConnected, MxDisconnected, MxLog, MxUser) + , MxAgentId(..) + , mxAgentWithFinalize + , mxSink + , mxReady + , mxReceive + , liftMX + , mxGetLocal + , mxSetLocal + , mxUpdateLocal + , mxNotify + ) +import Control.Distributed.Process.Extras + ( Resolvable(..) + , Routable(..) + , Addressable + ) +import Control.Distributed.Process.Serializable +import Control.Exception (SomeException) +import Control.Monad.Catch (catch) +import Data.Binary +import Data.Typeable (Typeable) +import GHC.Generics + +import Prelude hiding (error, Read) + +import System.IO + ( IOMode(AppendMode) + , BufferMode(..) + , openFile + , hClose + , hPutStrLn + , hSetBuffering + ) +import Text.Read (Read) + +data LogLevel = + Debug + | Info + | Notice + | Warning + | Error + | Critical + | Alert + | Emergency + deriving (Typeable, Generic, Eq, + Read, Show, Ord, Enum) +instance Binary LogLevel where +instance NFData LogLevel where rnf x = x `seq` () + +data SetLevel = SetLevel !LogLevel + deriving (Typeable, Generic) +instance Binary SetLevel where +instance NFData SetLevel where rnf x = x `seq` () + +newtype AddFormatter = AddFormatter (Closure (Message -> Process (Maybe String))) + deriving (Typeable, Generic, NFData) +instance Binary AddFormatter + +data LogState = + LogState { output :: !(String -> Process ()) + , cleanup :: !(Process ()) + , level :: !LogLevel + , format :: !(String -> Process String) + , formatters :: ![Message -> Process (Maybe String)] + } + +data LogMessage = + LogMessage !String !LogLevel + | LogData !Message !LogLevel + deriving (Typeable, Generic, Show) +instance Binary LogMessage where +instance NFData LogMessage where rnf x = x `seq` () + +type LogFormat = String -> Process String + +type LogChanT = () + +newtype LogChan = LogChan LogChanT +instance Routable LogChan where + sendTo _ = mxNotify + unsafeSendTo _ = mxNotify + +type LogText = String + +newtype LogClient = LogClient { agent :: ProcessId } +instance Resolvable LogClient where + resolve = return . Just . agent +instance Routable LogClient + +class ToLog m where + toLog :: (Serializable m) => m -> Process (LogLevel -> LogMessage) + toLog = return . LogData . unsafeWrapMessage + +instance ToLog LogText where + toLog = return . LogMessage + +instance ToLog Message where + toLog = return . LogData + +class Logger a where + logMessage :: a -> LogMessage -> Process () + +instance Logger LogClient where + logMessage = sendTo + +instance Logger LogChan where + logMessage _ = mxNotify + +logProcessName :: String +logProcessName = "service.systemlog" + +mxLogId :: MxAgentId +mxLogId = MxAgentId logProcessName + +logChannel :: LogChan +logChannel = LogChan () + +report :: (Logger l) + => (l -> LogText -> Process ()) + -> l + -> String + -> Process () +report f l = f l + +client :: Process (Maybe LogClient) +client = resolve logProcessName >>= return . maybe Nothing (Just . LogClient) + +debug :: (Logger l, Serializable m, ToLog m) => l -> m -> Process () +debug l m = sendLog l m Debug + +info :: (Logger l, Serializable m, ToLog m) => l -> m -> Process () +info l m = sendLog l m Info + +notice :: (Logger l, Serializable m, ToLog m) => l -> m -> Process () +notice l m = sendLog l m Notice + +warning :: (Logger l, Serializable m, ToLog m) => l -> m -> Process () +warning l m = sendLog l m Warning + +error :: (Logger l, Serializable m, ToLog m) => l -> m -> Process () +error l m = sendLog l m Error + +critical :: (Logger l, Serializable m, ToLog m) => l -> m -> Process () +critical l m = sendLog l m Critical + +alert :: (Logger l, Serializable m, ToLog m) => l -> m -> Process () +alert l m = sendLog l m Alert + +emergency :: (Logger l, Serializable m, ToLog m) => l -> m -> Process () +emergency l m = sendLog l m Emergency + +sendLog :: (Logger l, Serializable m, ToLog m) => l -> m -> LogLevel -> Process () +sendLog a m lv = toLog m >>= \m' -> logMessage a $ m' lv + +addFormatter :: (Addressable r) + => r + -> Closure (Message -> Process (Maybe String)) + -> Process () +addFormatter r clj = sendTo r $ AddFormatter clj + +-- | Start a system logger that writes to a file. +-- +-- This is a /very basic/ file logging facility, that uses /regular/ buffered +-- file I/O (i.e., @System.IO.hPutStrLn@ et al) under the covers. The handle +-- is closed appropriately if/when the logging process terminates. +-- +-- See @Control.Distributed.Process.Management.mxAgentWithFinalize@ for futher +-- details about management agents that use finalizers. +-- +systemLogFile :: FilePath -> LogLevel -> LogFormat -> Process ProcessId +systemLogFile path lvl fmt = do + h <- liftIO $ openFile path AppendMode + liftIO $ hSetBuffering h LineBuffering + systemLog (liftIO . hPutStrLn h) (liftIO (hClose h)) lvl fmt + +-- | Start a /system logger/ process as a management agent. +-- +systemLog :: (String -> Process ()) -- ^ This expression does the actual logging + -> (Process ()) -- ^ An expression used to clean up any residual state + -> LogLevel -- ^ The initial 'LogLevel' to use + -> LogFormat -- ^ An expression used to format logging messages/text + -> Process ProcessId +systemLog o c l f = go $ LogState o c l f defaultFormatters + where + go :: LogState -> Process ProcessId + go st = + mxAgentWithFinalize mxLogId st [ + -- these are the messages we're /really/ interested in + (mxSink $ \(m :: LogMessage) -> + case m of + (LogMessage msg lvl) -> + mxGetLocal >>= outputMin lvl msg >> mxReceive + (LogData dat lvl) -> handleRawMsg dat lvl) + + -- complex messages rely on properly registered formatters + , (mxSink $ \(ev :: MxEvent) -> + case ev of + (MxUser msg) -> handleRawMsg msg Debug + -- we treat trace/log events like regular log events at + -- a Debug level (only) + (MxLog str) -> mxGetLocal >>= outputMin Debug str >> mxReceive + _ -> handleEvent ev >> mxReceive) + + -- command message handling + , (mxSink $ \(SetLevel lvl) -> + mxGetLocal >>= \st' -> mxSetLocal st' { level = lvl } >> mxReceive) + , (mxSink $ \(AddFormatter f') -> do + fmt <- liftMX $ catch (unClosure f' >>= return . Just) + (\(_ :: SomeException) -> return Nothing) + case fmt of + Nothing -> mxReady + Just mf -> do + mxUpdateLocal (\s -> s { formatters = mf:formatters s }) + mxReceive) + ] runCleanup + + runCleanup = liftMX . cleanup =<< mxGetLocal + + handleRawMsg dat' lvl' = do + st <- mxGetLocal + msg <- formatMsg dat' st + case msg of + Just str -> outputMin lvl' str st >> mxReceive + Nothing -> mxReceive -- we cannot format a Message, so we ignore it + + handleEvent (MxConnected _ ep) = + mxGetLocal >>= outputMin Notice + ("Endpoint: " ++ show ep ++ " Disconnected") + handleEvent (MxDisconnected _ ep) = + mxGetLocal >>= outputMin Notice + ("Endpoint " ++ show ep ++ " Connected") + handleEvent _ = return () + + formatMsg m LogState{..} = let fms = formatters in formatMsg' m fms + + formatMsg' _ [] = return Nothing + formatMsg' m (f':fs) = do + res <- liftMX $ f' m + case res of + ok@(Just _) -> return ok + Nothing -> formatMsg' m fs + + outputMin minLvl msgData LogState{..} = + case minLvl >= level of + True -> liftMX (format msgData >>= output) + False -> return () + + defaultFormatters = [basicDataFormat] + +basicDataFormat :: Message -> Process (Maybe String) +basicDataFormat = unwrapMessage diff --git a/packages/distributed-process-extras/src/Control/Distributed/Process/Extras/Time.hs b/packages/distributed-process-extras/src/Control/Distributed/Process/Extras/Time.hs new file mode 100644 index 00000000..f9ec615d --- /dev/null +++ b/packages/distributed-process-extras/src/Control/Distributed/Process/Extras/Time.hs @@ -0,0 +1,258 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Distributed.Process.Extras.Time +-- Copyright : (c) Tim Watson, Jeff Epstein, Alan Zimmerman +-- License : BSD3 (see the file LICENSE) +-- +-- Maintainer : Tim Watson +-- Stability : experimental +-- Portability : non-portable (requires concurrency) +-- +-- This module provides facilities for working with time delays and timeouts. +-- The type 'Timeout' and the 'timeout' family of functions provide mechanisms +-- for working with @threadDelay@-like behaviour that operates on microsecond +-- values. +-- +-- The 'TimeInterval' and 'TimeUnit' related functions provide an abstraction +-- for working with various time intervals, whilst the 'Delay' type provides a +-- corrolary to 'timeout' that works with these. +----------------------------------------------------------------------------- + +module Control.Distributed.Process.Extras.Time + ( -- * Time interval handling + microSeconds + , milliSeconds + , seconds + , minutes + , hours + , asTimeout + , after + , within + , timeToMicros + , TimeInterval + , TimeUnit(..) + , Delay(..) + + -- * Conversion To/From NominalDiffTime + , timeIntervalToDiffTime + , diffTimeToTimeInterval + , diffTimeToDelay + , delayToDiffTime + , microsecondsToNominalDiffTime + + -- * (Legacy) Timeout Handling + , Timeout + , TimeoutNotification(..) + , timeout + , infiniteWait + , noWait + ) where + +import Control.Concurrent (threadDelay) +import Control.DeepSeq (NFData) +import Control.Distributed.Process +import Control.Distributed.Process.Extras.Internal.Types +import Control.Monad (void) +import Data.Binary +import Data.Ratio ((%)) +import Data.Time.Clock +import Data.Typeable (Typeable) + +import GHC.Generics + +-------------------------------------------------------------------------------- +-- API -- +-------------------------------------------------------------------------------- + +-- | Defines the time unit for a Timeout value +data TimeUnit = Days | Hours | Minutes | Seconds | Millis | Micros + deriving (Typeable, Generic, Eq, Show) + +instance Binary TimeUnit where +instance NFData TimeUnit where + +-- | A time interval. +data TimeInterval = TimeInterval TimeUnit Int + deriving (Typeable, Generic, Eq, Show) + +instance Binary TimeInterval where +instance NFData TimeInterval where + +-- | Represents either a delay of 'TimeInterval', an infinite wait or no delay +-- (i.e., non-blocking). +data Delay = Delay TimeInterval | Infinity | NoDelay + deriving (Typeable, Generic, Eq, Show) + +instance Binary Delay where +instance NFData Delay where + +-- | Represents a /timeout/ in terms of microseconds, where 'Nothing' stands for +-- infinity and @Just 0@, no-delay. +type Timeout = Maybe Int + +-- | Send to a process when a timeout expires. +data TimeoutNotification = TimeoutNotification Tag + deriving (Typeable) + +instance Binary TimeoutNotification where + get = fmap TimeoutNotification $ get + put (TimeoutNotification n) = put n + +-- time interval/unit handling + +-- | converts the supplied @TimeInterval@ to microseconds +asTimeout :: TimeInterval -> Int +asTimeout (TimeInterval u v) = timeToMicros u v + +-- | Convenience for making timeouts; e.g., +-- +-- > receiveTimeout (after 3 Seconds) [ match (\"ok" -> return ()) ] +-- +after :: Int -> TimeUnit -> Int +after n m = timeToMicros m n + +-- | Convenience for making 'TimeInterval'; e.g., +-- +-- > let ti = within 5 Seconds in ..... +-- +within :: Int -> TimeUnit -> TimeInterval +within n m = TimeInterval m n + +-- | given a number, produces a @TimeInterval@ of microseconds +microSeconds :: Int -> TimeInterval +microSeconds = TimeInterval Micros + +-- | given a number, produces a @TimeInterval@ of milliseconds +milliSeconds :: Int -> TimeInterval +milliSeconds = TimeInterval Millis + +-- | given a number, produces a @TimeInterval@ of seconds +seconds :: Int -> TimeInterval +seconds = TimeInterval Seconds + +-- | given a number, produces a @TimeInterval@ of minutes +minutes :: Int -> TimeInterval +minutes = TimeInterval Minutes + +-- | given a number, produces a @TimeInterval@ of hours +hours :: Int -> TimeInterval +hours = TimeInterval Hours + +-- TODO: is timeToMicros efficient enough? + +-- | converts the supplied @TimeUnit@ to microseconds +{-# INLINE timeToMicros #-} +timeToMicros :: TimeUnit -> Int -> Int +timeToMicros Micros us = us +timeToMicros Millis ms = ms * (10 ^ (3 :: Int)) -- (1000µs == 1ms) +timeToMicros Seconds secs = timeToMicros Millis (secs * milliSecondsPerSecond) +timeToMicros Minutes mins = timeToMicros Seconds (mins * secondsPerMinute) +timeToMicros Hours hrs = timeToMicros Minutes (hrs * minutesPerHour) +timeToMicros Days days = timeToMicros Hours (days * hoursPerDay) + +{-# INLINE hoursPerDay #-} +hoursPerDay :: Int +hoursPerDay = 24 + +{-# INLINE minutesPerHour #-} +minutesPerHour :: Int +minutesPerHour = 60 + +{-# INLINE secondsPerMinute #-} +secondsPerMinute :: Int +secondsPerMinute = 60 + +{-# INLINE milliSecondsPerSecond #-} +milliSecondsPerSecond :: Int +milliSecondsPerSecond = 1000 + +{-# INLINE microSecondsPerSecond #-} +microSecondsPerSecond :: Int +microSecondsPerSecond = 1000000 + +-- timeouts/delays (microseconds) + +-- | Constructs an inifinite 'Timeout'. +infiniteWait :: Timeout +infiniteWait = Nothing + +-- | Constructs a no-wait 'Timeout' +noWait :: Timeout +noWait = Just 0 + +-- | Sends the calling process @TimeoutNotification tag@ after @time@ microseconds +timeout :: Int -> Tag -> ProcessId -> Process () +timeout time tag p = + void $ spawnLocal $ + do liftIO $ threadDelay time + send p (TimeoutNotification tag) + +-- Converting to/from Data.Time.Clock NominalDiffTime + +-- | given a @TimeInterval@, provide an equivalent @NominalDiffTim@ +timeIntervalToDiffTime :: TimeInterval -> NominalDiffTime +timeIntervalToDiffTime ti = microsecondsToNominalDiffTime (fromIntegral $ asTimeout ti) + +-- | given a @NominalDiffTim@@, provide an equivalent @TimeInterval@ +diffTimeToTimeInterval :: NominalDiffTime -> TimeInterval +diffTimeToTimeInterval dt = microSeconds $ (fromIntegral (round (dt * 1000000) :: Integer)) + +-- | given a @Delay@, provide an equivalent @NominalDiffTim@ +delayToDiffTime :: Delay -> NominalDiffTime +delayToDiffTime (Delay ti) = timeIntervalToDiffTime ti +delayToDiffTime Infinity = error "trying to convert Delay.Infinity to a NominalDiffTime" +delayToDiffTime (NoDelay) = microsecondsToNominalDiffTime 0 + +-- | given a @NominalDiffTim@@, provide an equivalent @Delay@ +diffTimeToDelay :: NominalDiffTime -> Delay +diffTimeToDelay dt = Delay $ diffTimeToTimeInterval dt + +-- | Create a 'NominalDiffTime' from a number of microseconds. +microsecondsToNominalDiffTime :: Integer -> NominalDiffTime +microsecondsToNominalDiffTime x = fromRational (x % (fromIntegral microSecondsPerSecond)) + +-- tenYearsAsMicroSeconds :: Integer +-- tenYearsAsMicroSeconds = 10 * 365 * 24 * 60 * 60 * 1000000 + +-- | Allow @(+)@ and @(-)@ operations on @TimeInterval@s +instance Num TimeInterval where + t1 + t2 = microSeconds $ asTimeout t1 + asTimeout t2 + t1 - t2 = microSeconds $ asTimeout t1 - asTimeout t2 + _ * _ = error "trying to multiply two TimeIntervals" + abs t = microSeconds $ abs (asTimeout t) + signum t = if (asTimeout t) == 0 + then 0 + else if (asTimeout t) < 0 then -1 + else 1 + fromInteger _ = error "trying to call fromInteger for a TimeInterval. Cannot guess units" + +-- | Allow @(+)@ and @(-)@ operations on @Delay@s +instance Num Delay where + NoDelay + x = x + Infinity + _ = Infinity + x + NoDelay = x + _ + Infinity = Infinity + (Delay t1 ) + (Delay t2) = Delay (t1 + t2) + + NoDelay - x = x + Infinity - _ = Infinity + x - NoDelay = x + _ - Infinity = Infinity + (Delay t1 ) - (Delay t2) = Delay (t1 - t2) + + _ * _ = error "trying to multiply two Delays" + + abs NoDelay = NoDelay + abs Infinity = Infinity + abs (Delay t) = Delay (abs t) + + signum (NoDelay) = 0 + signum Infinity = 1 + signum (Delay t) = Delay (signum t) + + fromInteger 0 = NoDelay + fromInteger _ = error "trying to call fromInteger for a Delay. Cannot guess units" + diff --git a/packages/distributed-process-extras/src/Control/Distributed/Process/Extras/Timer.hs b/packages/distributed-process-extras/src/Control/Distributed/Process/Extras/Timer.hs new file mode 100644 index 00000000..f2eea2b5 --- /dev/null +++ b/packages/distributed-process-extras/src/Control/Distributed/Process/Extras/Timer.hs @@ -0,0 +1,180 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Distributed.Process.Extras.Timer +-- Copyright : (c) Tim Watson 2012 - 2017 +-- License : BSD3 (see the file LICENSE) +-- +-- Maintainer : Tim Watson +-- Stability : experimental +-- Portability : non-portable (requires concurrency) +-- +-- Provides an API for running code or sending messages, either after some +-- initial delay or periodically, and for cancelling, re-setting and/or +-- flushing pending /timers/. +----------------------------------------------------------------------------- + +module Control.Distributed.Process.Extras.Timer + ( + TimerRef + , Tick(Tick) + , sleep + , sleepFor + , sendAfter + , runAfter + , exitAfter + , killAfter + , startTimer + , ticker + , periodically + , resetTimer + , cancelTimer + , flushTimer + ) where + +import Control.DeepSeq (NFData(..)) +import Control.Distributed.Process hiding (send) +import Control.Distributed.Process.Serializable +import Control.Distributed.Process.Extras.UnsafePrimitives (send) +import Control.Distributed.Process.Extras.Internal.Types (NFSerializable) +import Control.Distributed.Process.Extras.Time +import Control.Monad (unless, void) +import Data.Binary +import Data.Typeable (Typeable) +import Prelude hiding (init) + +import GHC.Generics + +-- | an opaque reference to a timer +type TimerRef = ProcessId + +-- | cancellation message sent to timers +data TimerConfig = Reset | Cancel + deriving (Typeable, Generic, Eq, Show) +instance Binary TimerConfig where +instance NFData TimerConfig where + rnf tc = tc `seq` () + +-- | represents a 'tick' event that timers can generate +data Tick = Tick + deriving (Typeable, Generic, Eq, Show) +instance Binary Tick where +instance NFData Tick where + rnf t = t `seq` () + +data SleepingPill = SleepingPill + deriving (Typeable, Generic, Eq, Show) +instance Binary SleepingPill where +instance NFData SleepingPill where + +-------------------------------------------------------------------------------- +-- API -- +-------------------------------------------------------------------------------- + +-- | blocks the calling Process for the specified TimeInterval. Note that this +-- function assumes that a blocking receive is the most efficient approach to +-- acheiving this, however the runtime semantics (particularly with regards +-- scheduling) should not differ from threadDelay in practise. +sleep :: TimeInterval -> Process () +sleep t = + let ms = asTimeout t in do + _ <- receiveTimeout ms [matchIf (\SleepingPill -> True) + (\_ -> return ())] + return () + +-- | Literate way of saying @sleepFor 3 Seconds@. +sleepFor :: Int -> TimeUnit -> Process () +sleepFor i u = sleep (within i u) + +-- | starts a timer which sends the supplied message to the destination +-- process after the specified time interval. +sendAfter :: (NFSerializable a) + => TimeInterval + -> ProcessId + -> a + -> Process TimerRef +sendAfter t pid msg = runAfter t proc + where proc = send pid msg + +-- | runs the supplied process action(s) after @t@ has elapsed +runAfter :: TimeInterval -> Process () -> Process TimerRef +runAfter t p = spawnLocal $ runTimer t p True + +-- | calls @exit pid reason@ after @t@ has elapsed +exitAfter :: (Serializable a) + => TimeInterval + -> ProcessId + -> a + -> Process TimerRef +exitAfter delay pid reason = runAfter delay $ exit pid reason + +-- | kills the specified process after @t@ has elapsed +killAfter :: TimeInterval -> ProcessId -> String -> Process TimerRef +killAfter delay pid why = runAfter delay $ kill pid why + +-- | starts a timer that repeatedly sends the supplied message to the destination +-- process each time the specified time interval elapses. To stop messages from +-- being sent in future, 'cancelTimer' can be called. +startTimer :: (NFSerializable a) + => TimeInterval + -> ProcessId + -> a + -> Process TimerRef +startTimer t pid msg = periodically t (send pid msg) + +-- | runs the supplied process action(s) repeatedly at intervals of @t@ +periodically :: TimeInterval -> Process () -> Process TimerRef +periodically t p = spawnLocal $ runTimer t p False + +-- | resets a running timer. Note: Cancelling a timer does not guarantee that +-- all its messages are prevented from being delivered to the target process. +-- Also note that resetting an ongoing timer (started using the 'startTimer' or +-- 'periodically' functions) will only cause the current elapsed period to time +-- out, after which the timer will continue running. To stop a long-running +-- timer permanently, you should use 'cancelTimer' instead. +resetTimer :: TimerRef -> Process () +resetTimer = flip send Reset + +-- | permanently cancels a timer +cancelTimer :: TimerRef -> Process () +cancelTimer = flip send Cancel + +-- | cancels a running timer and flushes any viable timer messages from the +-- process' message queue. This function should only be called by the process +-- expecting to receive the timer's messages! +flushTimer :: (Serializable a, Eq a) => TimerRef -> a -> Delay -> Process () +flushTimer ref ignore t = do + mRef <- monitor ref + cancelTimer ref + performFlush mRef t + return () + where performFlush mRef Infinity = receiveWait $ filters mRef + performFlush mRef NoDelay = performFlush mRef (Delay $ microSeconds 0) + performFlush mRef (Delay i) = void (receiveTimeout (asTimeout i) (filters mRef)) + filters mRef = [ + matchIf (== ignore) + (\_ -> return ()) + , matchIf (\(ProcessMonitorNotification mRef' _ _) -> mRef == mRef') + (\_ -> return ()) ] + +-- | sets up a timer that sends 'Tick' repeatedly at intervals of @t@ +ticker :: TimeInterval -> ProcessId -> Process TimerRef +ticker t pid = startTimer t pid Tick + +-------------------------------------------------------------------------------- +-- Implementation -- +-------------------------------------------------------------------------------- + +-- runs the timer process +runTimer :: TimeInterval -> Process () -> Bool -> Process () +runTimer t proc cancelOnReset = do + cancel <- expectTimeout (asTimeout t) + -- say $ "cancel = " ++ (show cancel) ++ "\n" + case cancel of + Nothing -> runProc cancelOnReset + Just Cancel -> return () + Just Reset -> unless cancelOnReset $ runTimer t proc cancelOnReset + where runProc True = proc + runProc False = proc >> runTimer t proc cancelOnReset diff --git a/packages/distributed-process-extras/src/Control/Distributed/Process/Extras/UnsafePrimitives.hs b/packages/distributed-process-extras/src/Control/Distributed/Process/Extras/UnsafePrimitives.hs new file mode 100644 index 00000000..31378133 --- /dev/null +++ b/packages/distributed-process-extras/src/Control/Distributed/Process/Extras/UnsafePrimitives.hs @@ -0,0 +1,62 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Control.Distributed.Process.Extras.UnsafePrimitives +-- Copyright : (c) Tim Watson 2013 - 2017 +-- License : BSD3 (see the file LICENSE) +-- +-- Maintainer : Tim Watson +-- Stability : experimental +-- Portability : non-portable (requires concurrency) +-- +-- [Unsafe Messaging Primitives Using NFData] +-- +-- This module mirrors "Control.Distributed.Process.UnsafePrimitives", but +-- attempts to provide a bit more safety by forcing evaluation before sending. +-- This is handled using @NFData@, by means of the @NFSerializable@ type class. +-- +-- Note that we /still/ cannot guarantee that both the @NFData@ and @Binary@ +-- instances will evaluate your data the same way, therefore these primitives +-- still have certain risks and potential side effects. Use with caution. +-- +----------------------------------------------------------------------------- +module Control.Distributed.Process.Extras.UnsafePrimitives + ( send + , nsend + , sendToAddr + , sendChan + , wrapMessage + ) where + +import Control.DeepSeq (($!!)) +import Control.Distributed.Process + ( Process + , ProcessId + , SendPort + , Message + ) +import Control.Distributed.Process.Extras.Internal.Types + ( NFSerializable + , Addressable + , Resolvable(..) + ) +import qualified Control.Distributed.Process.UnsafePrimitives as Unsafe + +send :: NFSerializable m => ProcessId -> m -> Process () +send pid msg = Unsafe.send pid $!! msg + +nsend :: NFSerializable a => String -> a -> Process () +nsend name msg = Unsafe.nsend name $!! msg + +sendToAddr :: (Addressable a, NFSerializable m) => a -> m -> Process () +sendToAddr addr msg = do + mPid <- resolve addr + case mPid of + Nothing -> return () + Just p -> send p msg + +sendChan :: (NFSerializable m) => SendPort m -> m -> Process () +sendChan port msg = Unsafe.sendChan port $!! msg + +-- | Create an unencoded @Message@ for any @Serializable@ type. +wrapMessage :: NFSerializable a => a -> Message +wrapMessage msg = Unsafe.wrapMessage $!! msg diff --git a/packages/distributed-process-extras/tests/TestLog.hs b/packages/distributed-process-extras/tests/TestLog.hs new file mode 100644 index 00000000..94f5385f --- /dev/null +++ b/packages/distributed-process-extras/tests/TestLog.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +-- import Control.Exception (SomeException) +import Control.Concurrent.MVar (MVar, newMVar, takeMVar, putMVar, newEmptyMVar) +import Control.Concurrent.STM (atomically) +import Control.Concurrent.STM.TChan +import Control.Distributed.Process hiding (monitor) +import Control.Distributed.Process.Closure (remotable, mkStaticClosure) +import Control.Distributed.Process.Node +import Control.Distributed.Process.Extras hiding (__remoteTable) +import qualified Control.Distributed.Process.Extras.SystemLog as Log (Logger, error) +import Control.Distributed.Process.Extras.SystemLog hiding (Logger, error) +import Control.Distributed.Process.SysTest.Utils +import Control.Distributed.Process.Extras.Time +import Control.Distributed.Process.Extras.Timer +import Control.Monad (void) +import Data.List (delete) + +import Prelude hiding (drop, read, Read) + +import Test.Framework (Test, testGroup, defaultMain) +import Test.Framework.Providers.HUnit (testCase) +import Network.Transport.TCP +import qualified Network.Transport as NT + +import GHC.Read +import Text.ParserCombinators.ReadP as P +import Text.ParserCombinators.ReadPrec + +import qualified Network.Transport as NT + +logLevelFormatter :: Message -> Process (Maybe String) +logLevelFormatter m = handleMessage m showLevel + where + showLevel :: LogLevel -> Process String + showLevel = return . show + +$(remotable ['logLevelFormatter]) + +logFormat :: Closure (Message -> Process (Maybe String)) +logFormat = $(mkStaticClosure 'logLevelFormatter) + +testLoggingProcess :: Process (ProcessId, TChan String) +testLoggingProcess = do + chan <- liftIO $ newTChanIO + let cleanup = return () + let format = return + pid <- systemLog (writeLog chan) cleanup Debug format + addFormatter pid logFormat + sleep $ seconds 1 + return (pid, chan) + where + writeLog chan = liftIO . atomically . writeTChan chan + +testLogLevels :: (Log.Logger logger, NFSerializable tL, ToLog tL) + => MVar () + -> TChan String + -> logger + -> LogLevel + -> LogLevel + -> (LogLevel -> tL) + -> TestResult Bool + -> Process () +testLogLevels lck chan logger from to fn result = do + void $ liftIO $ takeMVar lck + let lvls = enumFromTo from to + logIt logger fn lvls + testHarness lvls chan result + liftIO $ putMVar lck () + where + logIt _ _ [] = return () + logIt lc f (l:ls) = sendLog lc (f l) l >> logIt lc f ls + +testHarness :: [LogLevel] + -> TChan String + -> TestResult Bool + -> Process () +testHarness [] chan result = do + liftIO (atomically (isEmptyTChan chan)) >>= stash result +testHarness levels chan result = do + msg <- liftIO $ atomically $ readTChan chan + -- liftIO $ putStrLn $ "testHarness handling " ++ msg + let item = readEither msg + case item of + Right i -> testHarness (delete i levels) chan result + Left _ -> testHarness levels chan result + where + readEither :: String -> Either String LogLevel + readEither s = + case [ x | (x,"") <- readPrec_to_S read' minPrec s ] of + [x] -> Right x + _ -> Left "read: ambiguous parse" + + read' = + do x <- readPrec + lift P.skipSpaces + return x + +tests :: NT.Transport -> IO [Test] +tests transport = do + let ch = logChannel + localNode <- newLocalNode transport $ __remoteTable initRemoteTable + lock <- newMVar () + ex <- newEmptyMVar + void $ forkProcess localNode $ do (_, chan) <- testLoggingProcess + liftIO $ putMVar ex chan + chan <- takeMVar ex + return [ + testGroup "Log Reports / LogText" + (map (mkTestCase lock chan ch simpleShowToLog localNode) (enumFromTo Debug Emergency)) + , testGroup "Logging Raw Messages" + (map (mkTestCase lock chan ch messageToLog localNode) (enumFromTo Debug Emergency)) + , testGroup "Custom Formatters" + (map (mkTestCase lock chan ch messageRaw localNode) (enumFromTo Debug Emergency)) + ] + where + mkTestCase lck chan ch' rdr ln lvl = do + let l = show lvl + testCase l (delayedAssertion ("Expected up to " ++ l) + ln True $ testLogLevels lck chan ch' Debug lvl rdr) + + simpleShowToLog = show + messageToLog = unsafeWrapMessage . show + messageRaw = unsafeWrapMessage + +-- | Given a @builder@ function, make and run a test suite on a single transport +testMain :: (NT.Transport -> IO [Test]) -> IO () +testMain builder = do + Right (transport, _) <- createTransportExposeInternals (defaultTCPAddr "127.0.0.1" "0") defaultTCPParameters + testData <- builder transport + defaultMain testData + +main :: IO () +main = testMain $ tests + diff --git a/packages/distributed-process-extras/tests/TestPrimitives.hs b/packages/distributed-process-extras/tests/TestPrimitives.hs new file mode 100644 index 00000000..baa9de42 --- /dev/null +++ b/packages/distributed-process-extras/tests/TestPrimitives.hs @@ -0,0 +1,220 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TemplateHaskell #-} + +module Main where + +import Control.Concurrent (threadDelay) +import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar) +import Control.Distributed.Process +import Control.Distributed.Process.Node +import Control.Distributed.Process.Serializable() + +import Control.Distributed.Process.Extras hiding (__remoteTable, monitor, send) +import qualified Control.Distributed.Process.Extras (__remoteTable) +import Control.Distributed.Process.Extras.Call +import Control.Distributed.Process.Extras.Monitoring +import Control.Distributed.Process.Extras.Time +import Control.Monad (void) +import Control.Rematch hiding (match) +import qualified Network.Transport as NT (Transport) +import Network.Transport.TCP() + +import Test.HUnit (Assertion) +import Test.Framework (Test, testGroup, defaultMain) +import Test.Framework.Providers.HUnit (testCase) +import Network.Transport.TCP +import qualified Network.Transport as NT +import Control.Distributed.Process.SysTest.Utils + +testLinkingWithNormalExits :: TestResult DiedReason -> Process () +testLinkingWithNormalExits result = do + testPid <- getSelfPid + pid <- spawnLocal $ do + worker <- spawnLocal $ do + "finish" <- expect + return () + linkOnFailure worker + send testPid worker + () <- expect + return () + + workerPid <- expect :: Process ProcessId + ref <- monitor workerPid + + send workerPid "finish" + receiveWait [ + matchIf (\(ProcessMonitorNotification ref' _ _) -> ref == ref') + (\_ -> return ()) + ] + + -- by now, the worker is gone, so we can check that the + -- insulator is still alive and well and that it exits normally + -- when asked to do so + ref2 <- monitor pid + send pid () + + r <- receiveWait [ + matchIf (\(ProcessMonitorNotification ref2' _ _) -> ref2 == ref2') + (\(ProcessMonitorNotification _ _ reason) -> return reason) + ] + stash result r + +testLinkingWithAbnormalExits :: TestResult (Maybe Bool) -> Process () +testLinkingWithAbnormalExits result = do + testPid <- getSelfPid + pid <- spawnLocal $ do + worker <- spawnLocal $ do + "finish" <- expect + return () + + linkOnFailure worker + send testPid worker + () <- expect + return () + + workerPid <- expect :: Process ProcessId + + ref <- monitor pid + kill workerPid "finish" -- note the use of 'kill' instead of send + r <- receiveTimeout (asTimeout $ seconds 20) [ + matchIf (\(ProcessMonitorNotification ref' _ _) -> ref == ref') + (\(ProcessMonitorNotification _ _ reason) -> return reason) + ] + case r of + Just (DiedException _) -> stash result $ Just True + (Just _) -> stash result $ Just False + Nothing -> stash result Nothing + +testMonitorNodeDeath :: NT.Transport -> TestResult () -> Process () +testMonitorNodeDeath transport result = do + void $ nodeMonitor >> monitorNodes -- start node monitoring + + nid1 <- getSelfNode + nid2 <- liftIO $ newEmptyMVar + nid3 <- liftIO $ newEmptyMVar + + node2 <- liftIO $ newLocalNode transport initRemoteTable + node3 <- liftIO $ newLocalNode transport initRemoteTable + + -- sending to (nodeId, "ignored") is a short cut to force a connection + liftIO $ tryForkProcess node2 $ ensureNodeRunning nid2 (nid1, "ignored") + liftIO $ tryForkProcess node3 $ ensureNodeRunning nid3 (nid1, "ignored") + + NodeUp _ <- expect + NodeUp _ <- expect + + void $ liftIO $ closeLocalNode node2 + void $ liftIO $ closeLocalNode node3 + + NodeDown n1 <- expect + NodeDown n2 <- expect + + mn1 <- liftIO $ takeMVar nid2 + mn2 <- liftIO $ takeMVar nid3 + + [mn1, mn2] `shouldContain` n1 + [mn1, mn2] `shouldContain` n2 + + nid4 <- liftIO $ newEmptyMVar + node4 <- liftIO $ newLocalNode transport initRemoteTable + void $ liftIO $ runProcess node4 $ do + us <- getSelfNode + liftIO $ putMVar nid4 us + monitorNode nid1 >> return () + + mn3 <- liftIO $ takeMVar nid4 + NodeUp n3 <- expect + mn3 `shouldBe` (equalTo n3) + + liftIO $ closeLocalNode node4 + stash result () + + where + ensureNodeRunning mvar nid = do + us <- getSelfNode + liftIO $ putMVar mvar us + sendTo nid "connected" + +myRemoteTable :: RemoteTable +myRemoteTable = Control.Distributed.Process.Extras.__remoteTable initRemoteTable + +multicallTest :: NT.Transport -> Assertion +multicallTest transport = + do node1 <- newLocalNode transport myRemoteTable + tryRunProcess node1 $ + do pid1 <- whereisOrStart "server1" server1 + _ <- whereisOrStart "server2" server2 + pid2 <- whereisOrStart "server2" server2 + tag <- newTagPool + + -- First test: expect positives answers from both processes + tag1 <- getTag tag + result1 <- multicall [pid1,pid2] mystr tag1 infiniteWait + case result1 of + [Just reversed, Just doubled] | + reversed == reverse mystr && doubled == mystr ++ mystr -> return () + _ -> error "Unmatched" + + -- Second test: First process works, second thread throws an exception + tag2 <- getTag tag + [Just 10, Nothing] <- multicall [pid1,pid2] (5::Int) tag2 infiniteWait :: Process [Maybe Int] + + -- Third test: First process exceeds time limit, second process is still dead + tag3 <- getTag tag + [Nothing, Nothing] <- multicall [pid1,pid2] (23::Int) tag3 (Just 1000000) :: Process [Maybe Int] + return () + where server1 = receiveWait [callResponse (\str -> mention (str::String) (return (reverse str,())))] >> + receiveWait [callResponse (\i -> mention (i::Int) (return (i*2,())))] >> + receiveWait [callResponse (\i -> liftIO (threadDelay 2000000) >> mention (i::Int) (return (i*10,())))] + server2 = receiveWait [callResponse (\str -> mention (str::String) (return (str++str,())))] >> + receiveWait [callResponse (\i -> error "barf" >> mention (i::Int) (return (i :: Int,())))] + mystr = "hello" + mention :: a -> b -> b + mention _a b = b + + + +-------------------------------------------------------------------------------- +-- Utilities and Plumbing -- +-------------------------------------------------------------------------------- + +tests :: NT.Transport -> LocalNode -> [Test] +tests transport localNode = [ + testGroup "Linking Tests" [ + testCase "testLinkingWithNormalExits" + (delayedAssertion + "normal exit should not terminate the caller" + localNode DiedNormal testLinkingWithNormalExits) + , testCase "testLinkingWithAbnormalExits" + (delayedAssertion + "abnormal exit should terminate the caller" + localNode (Just True) testLinkingWithAbnormalExits) + ], + testGroup "Call/RPC" [ + testCase "multicallTest" (multicallTest transport) + ] + -- TODO: the test below has been very flaky in CI + -- testGroup "Node Monitoring" [ + -- testCase "Death Notifications" + -- (delayedAssertion + -- "subscribers should both have received NodeDown twice" + -- localNode () (testMonitorNodeDeath transport)) + -- ] + ] + +primitivesTests :: NT.Transport -> IO [Test] +primitivesTests transport = do + localNode <- newLocalNode transport initRemoteTable + let testData = tests transport localNode + return testData + +-- | Given a @builder@ function, make and run a test suite on a single transport +testMain :: (NT.Transport -> IO [Test]) -> IO () +testMain builder = do + Right (transport, _) <- createTransportExposeInternals (defaultTCPAddr "127.0.0.1" "0") defaultTCPParameters + testData <- builder transport + defaultMain testData + +main :: IO () +main = testMain $ primitivesTests diff --git a/packages/distributed-process-extras/tests/TestQueues.hs b/packages/distributed-process-extras/tests/TestQueues.hs new file mode 100644 index 00000000..881a7f00 --- /dev/null +++ b/packages/distributed-process-extras/tests/TestQueues.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE PatternGuards #-} +module Main where + +import qualified Control.Distributed.Process.Extras.Internal.Queue.SeqQ as FIFO +import Control.Distributed.Process.Extras.Internal.Queue.SeqQ ( SeqQ ) +import qualified Control.Distributed.Process.Extras.Internal.Queue.PriorityQ as PQ + +import Control.Rematch hiding (on) +import Control.Rematch.Run +import Data.Function (on) +import Data.List +import Test.Framework as TF (defaultMain, testGroup, Test) +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.HUnit (Assertion, assertFailure) + +import Prelude + +expectThat :: a -> Matcher a -> Assertion +expectThat a matcher = case res of + MatchSuccess -> return () + (MatchFailure msg) -> assertFailure msg + where res = runMatch matcher a + +-- NB: these tests/properties are not meant to be complete, but rather +-- they exercise the small number of behaviours that we actually use! + +-- TODO: some laziness vs. strictness tests, with error/exception checking + +prop_pq_ordering :: [Int] -> Bool +prop_pq_ordering xs = + let xs' = map (\x -> (x, show x)) xs + q = foldl (\q' x -> PQ.enqueue (fst x) (snd x) q') PQ.empty xs' + ys = drain q [] + zs = [snd x | x <- reverse $ sortBy (compare `on` fst) xs'] + -- the sorted list should match the stuff we drained back out + in zs == ys + where + drain q xs' + | True <- PQ.isEmpty q = xs' + | otherwise = + let Just (x, q') = PQ.dequeue q in drain q' (x:xs') + +prop_fifo_enqueue :: Int -> Int -> Int -> Bool +prop_fifo_enqueue a b c = + let q1 = foldl FIFO.enqueue FIFO.empty [a,b,c] + Just (a', q2) = FIFO.dequeue q1 + Just (b', q3) = FIFO.dequeue q2 + Just (c', q4) = FIFO.dequeue q3 + d = FIFO.dequeue q4 + in (d == Nothing) && (q4 `seq` [a',b',c'] == [a,b,c]) -- why seq here? to shut the compiler up. + +prop_enqueue_empty :: String -> Bool +prop_enqueue_empty s = + let q = FIFO.enqueue FIFO.empty s + Just (_, q') = FIFO.dequeue q + in (FIFO.isEmpty q') == ((FIFO.isEmpty q) == False) + +tests :: [TF.Test] +tests = [ + testGroup "Priority Queue Tests" [ + -- testCase "New Queue Should Be Empty" + -- (expect (PQ.isEmpty $ PQ.empty) $ equalTo True), + -- testCase "Singleton Queue Should Contain One Element" + -- (expect (PQ.dequeue $ (PQ.singleton 1 "hello") :: PriorityQ Int String) $ + -- equalTo $ (Just ("hello", PQ.empty)) :: Maybe (PriorityQ Int String)), + -- testCase "Dequeue Empty Queue Should Be Nothing" + -- (expect (Q.isEmpty $ PQ.dequeue $ + -- (PQ.empty :: PriorityQ Int ())) $ equalTo True), + testProperty "Enqueue/Dequeue should respect Priority order" + prop_pq_ordering + ], + testGroup "FIFO Queue Tests" [ + testCase "New Queue Should Be Empty" + (expectThat (FIFO.isEmpty $ FIFO.empty) $ equalTo True), + testCase "Singleton Queue Should Contain One Element" + (expectThat (FIFO.dequeue $ FIFO.singleton "hello") $ + equalTo $ Just ("hello", FIFO.empty)), + testCase "Dequeue Empty Queue Should Be Nothing" + (expectThat (FIFO.dequeue $ (FIFO.empty :: SeqQ ())) $ + is (Nothing :: Maybe ((), SeqQ ()))), + testProperty "Enqueue/Dequeue should respect FIFO order" + prop_fifo_enqueue, + testProperty "Enqueue/Dequeue should respect isEmpty" + prop_enqueue_empty + ] + ] + +main :: IO () +main = defaultMain tests + diff --git a/packages/distributed-process-extras/tests/TestTimer.hs b/packages/distributed-process-extras/tests/TestTimer.hs new file mode 100644 index 00000000..a021b2cb --- /dev/null +++ b/packages/distributed-process-extras/tests/TestTimer.hs @@ -0,0 +1,191 @@ +{-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE CPP #-} +module Main where + +import Control.Monad (forever) +import Control.Concurrent.MVar + ( newEmptyMVar + , putMVar + , takeMVar + , withMVar + ) +import qualified Network.Transport as NT (Transport) +import Network.Transport.TCP() +import Control.DeepSeq (NFData) +import Control.Distributed.Process +import Control.Distributed.Process.Node +import Control.Distributed.Process.Serializable() +import Control.Distributed.Process.Extras.Time +import Control.Distributed.Process.Extras.Timer +import Control.Distributed.Process.SysTest.Utils + +import Test.Framework (Test, testGroup, defaultMain) +import Test.Framework.Providers.HUnit (testCase) +import Network.Transport.TCP +import qualified Network.Transport as NT + +instance NFData Ping where + +testSendAfter :: TestResult Bool -> Process () +testSendAfter result = + let delay = seconds 1 in do + sleep $ seconds 10 + pid <- getSelfPid + _ <- sendAfter delay pid Ping + hdInbox <- receiveTimeout (asTimeout (seconds 2)) [ + match (\m@(Ping) -> return m) + ] + case hdInbox of + Just Ping -> stash result True + Nothing -> stash result False + +testRunAfter :: TestResult Bool -> Process () +testRunAfter result = + let delay = seconds 2 in do + + parentPid <- getSelfPid + _ <- spawnLocal $ do + _ <- runAfter delay $ send parentPid Ping + return () + + msg <- expectTimeout ((asTimeout delay) * 4) + case msg of + Just Ping -> stash result True + Nothing -> stash result False + return () + +testCancelTimer :: TestResult Bool -> Process () +testCancelTimer result = do + let delay = milliSeconds 50 + pid <- periodically delay noop + ref <- monitor pid + _ <- getProcessInfo pid + + cancelTimer pid + + _ <- receiveWait [ + match (\(ProcessMonitorNotification ref' pid' _) -> + stash result $ ref == ref' && pid == pid') + ] + + return () + +testPeriodicSend :: TestResult Bool -> Process () +testPeriodicSend result = do + let delay = milliSeconds 100 + self <- getSelfPid + ref <- ticker delay self + listener 0 ref + liftIO $ putMVar result True + where listener :: Int -> TimerRef -> Process () + listener n tRef | n > 10 = cancelTimer tRef + | otherwise = waitOne >> listener (n + 1) tRef + -- get a single tick, blocking indefinitely + waitOne :: Process () + waitOne = do + Tick <- expect + return () + +testTimerReset :: TestResult Int -> Process () +testTimerReset result = do + let delay = seconds 10 + counter <- liftIO $ newEmptyMVar + + listenerPid <- spawnLocal $ do + stash counter 0 + -- we continually listen for 'ticks' and increment counter for each + forever $ do + Tick <- expect + liftIO $ withMVar counter (\n -> (return (n + 1))) + + -- this ticker will 'fire' every 10 seconds + ref <- ticker delay listenerPid + + sleep $ seconds 2 + resetTimer ref + + -- at this point, the timer should be back to roughly a 5 second count down + -- so our few remaining cycles no ticks ought to make it to the listener + -- therefore we kill off the timer and the listener now and take the count + cancelTimer ref + kill listenerPid "stop!" + + -- how many 'ticks' did the listener observer? (hopefully none!) + count <- liftIO $ takeMVar counter + liftIO $ putMVar result count + +testTimerFlush :: TestResult Bool -> Process () +testTimerFlush result = do + let delay = seconds 1 + self <- getSelfPid + ref <- ticker delay self + + -- sleep so we *should* have a message in our 'mailbox' + sleep $ milliSeconds 2 + + -- flush it out if it's there + flushTimer ref Tick (Delay $ seconds 3) + + m <- expectTimeout 10 + case m of + Nothing -> stash result True + Just Tick -> stash result False + +testSleep :: TestResult Bool -> Process () +testSleep r = do + sleep $ seconds 20 + stash r True + +-------------------------------------------------------------------------------- +-- Utilities and Plumbing -- +-------------------------------------------------------------------------------- + +tests :: LocalNode -> [Test] +tests localNode = [ + testGroup "Timer Tests" [ + testCase "testSendAfter" + (delayedAssertion + "expected Ping within 1 second" + localNode True testSendAfter) + , testCase "testRunAfter" + (delayedAssertion + "expecting run (which pings parent) within 2 seconds" + localNode True testRunAfter) + , testCase "testCancelTimer" + (delayedAssertion + "expected cancelTimer to exit the timer process normally" + localNode True testCancelTimer) + , testCase "testPeriodicSend" + (delayedAssertion + "expected ten Ticks to have been sent before exiting" + localNode True testPeriodicSend) + , testCase "testTimerReset" + (delayedAssertion + "expected no Ticks to have been sent before resetting" + localNode 0 testTimerReset) + , testCase "testTimerFlush" + (delayedAssertion + "expected all Ticks to have been flushed" + localNode True testTimerFlush) + , testCase "testSleep" + (delayedAssertion + "why am I not seeing a delay!?" + localNode True testTimerFlush) + ] + ] + +timerTests :: NT.Transport -> IO [Test] +timerTests transport = do + localNode <- newLocalNode transport initRemoteTable + let testData = tests localNode + return testData + +-- | Given a @builder@ function, make and run a test suite on a single transport +testMain :: (NT.Transport -> IO [Test]) -> IO () +testMain builder = do + Right (transport, _) <- createTransportExposeInternals (defaultTCPAddr "127.0.0.1" "0") defaultTCPParameters + testData <- builder transport + defaultMain testData + +main :: IO () +main = testMain $ timerTests diff --git a/packages/distributed-process-simplelocalnet/ChangeLog b/packages/distributed-process-simplelocalnet/ChangeLog new file mode 100644 index 00000000..b968bf96 --- /dev/null +++ b/packages/distributed-process-simplelocalnet/ChangeLog @@ -0,0 +1,82 @@ +2024-08-28 Laurent P. René de Cotret 0.3.1 + +* Now tested with GHC 9.10.1. +* Updated dependency bounds. + +2024-03-27 Laurent P. René de Cotret 0.3.0 + +* Breaking change: update dependency bounds to require network-3.0. +* Use various functions from the `exceptions` package instead of the deprecated ones from `distributed-process`. + +2017-08-22 Facundo Domínguez 0.2.4 + +* Update dependency bounds to build with ghc-8.2.1. + +2016-10-13 Facundo Domínguez 0.2.3.3 + +* Update dependency bounds. + +2016-02-16 Facundo Domínguez 0.2.3.2 + +* Update dependency bounds. + +2015-01-29 Facundo Domínguez 0.2.3.1 + +* Update dependency bounds. + +2013-01-27 Facundo Domínguez 0.2.3.0 + +* Fix dependency bounds. +* Minor improvements to tests. + +2013-01-27 Tim Watson 0.2.2.0 + +* Bump dependencies + +2013-01-27 Tim Watson 0.2.1.0 + +2013-01-27 Tim Watson 0.2.0.9 + +* Shut down the logger process before exiting +* Improvements to the redirection of logging +* Fix restarting of master + +2012-11-22 Edsko de Vries 0.2.0.8 + +* Use the new 'register' semantics (depends on distributed-process-0.4.1). +Patch by Jeff Epstein +* Relax package bounds to allow for Binary 0.6 + +2012-10-23 Edsko de Vries 0.2.0.7 + +* Fix cabal script so that the example program compiles + +2012-10-03 Edsko de Vries 0.2.0.6 + +* Use new version of network-transport +* network-2.4.0 compatibility +* Relax upper bound on distributed-process dependency + +2012-08-22 Edsko de Vries 0.2.0.5 + +* Don't assume slaves are still alive in findSlaves + +2012-08-09 Edsko de Vries 0.2.0.4 + +* Relax version bounds for distributed-process + +2012-07-17 Edsko de Vries 0.2.0.3 + +* Improve documentation + +2012-07-16 Edsko de Vries 0.2.0.2 + +* Relax contraints on bytestring and containers + +2012-07-09 Edsko de Vries 0.2.0.1 + +* Bugfix: Documentation referred to old module name + +2012-07-07 Edsko de Vries 0.2.0 + +* Initial release. diff --git a/distributed-process-tests/LICENSE b/packages/distributed-process-simplelocalnet/LICENSE similarity index 100% rename from distributed-process-tests/LICENSE rename to packages/distributed-process-simplelocalnet/LICENSE diff --git a/packages/distributed-process-simplelocalnet/distributed-process-simplelocalnet.cabal b/packages/distributed-process-simplelocalnet/distributed-process-simplelocalnet.cabal new file mode 100644 index 00000000..141bc648 --- /dev/null +++ b/packages/distributed-process-simplelocalnet/distributed-process-simplelocalnet.cabal @@ -0,0 +1,66 @@ +cabal-version: 3.0 +Name: distributed-process-simplelocalnet +Version: 0.3.1 +Build-Type: Simple +License: BSD-3-Clause +License-File: LICENSE +Copyright: Well-Typed LLP +Author: Duncan Coutts, Nicolas Wu, Edsko de Vries +maintainer: The Distributed Haskell team +Stability: experimental +Homepage: http://haskell-distributed.github.com +Bug-Reports: https://github.com/haskell-distributed/distributed-process-simplelocalnet/issues +Synopsis: Simple zero-configuration backend for Cloud Haskell +Description: Simple backend based on the TCP transport which offers node + discovery based on UDP multicast. This is a zero-configuration + backend designed to get you going with Cloud Haskell quickly + without imposing any structure on your application. +tested-with: GHC==8.10.7 GHC==9.0.2 GHC==9.2.8 GHC==9.4.5 GHC==9.6.4 GHC==9.8.2 GHC==9.10.1 +Category: Control +extra-source-files: ChangeLog + +Source-Repository head + Type: git + Location: https://github.com/haskell-distributed/distributed-process-simplelocalnet + +common warnings + ghc-options: -Wall + -Wcompat + -Widentities + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wredundant-constraints + -fhide-source-paths + -Wpartial-fields + +Library + import: warnings + Build-Depends: base >= 4.14 && < 5, + bytestring >= 0.10 && < 0.13, + exceptions >= 0.10 && <0.11, + network >= 3.0 && < 3.3, + network-multicast >= 0.1.1 && < 0.4, + data-accessor >= 0.2 && < 0.3, + binary >= 0.8 && < 0.9, + containers >= 0.6 && < 0.8, + transformers >= 0.2 && < 0.7, + network-transport >= 0.5 && < 0.6, + network-transport-tcp >= 0.4 && < 0.9, + distributed-process >= 0.5.0 && < 0.8 + Exposed-modules: Control.Distributed.Process.Backend.SimpleLocalnet, + Control.Distributed.Process.Backend.SimpleLocalnet.Internal.Multicast + Default-Language: Haskell2010 + HS-Source-Dirs: src + +Test-Suite SimpleLocalNet-TestSuite + import: warnings + Type: exitcode-stdio-1.0 + Hs-Source-Dirs: tests + Main-Is: Main.hs + Default-Language: Haskell2010 + ghc-options: -threaded -with-rtsopts=-N + Build-Depends: base + , distributed-process + , distributed-process-simplelocalnet + , tasty + , tasty-hunit diff --git a/packages/distributed-process-simplelocalnet/src/Control/Distributed/Process/Backend/SimpleLocalnet.hs b/packages/distributed-process-simplelocalnet/src/Control/Distributed/Process/Backend/SimpleLocalnet.hs new file mode 100644 index 00000000..9215d5f8 --- /dev/null +++ b/packages/distributed-process-simplelocalnet/src/Control/Distributed/Process/Backend/SimpleLocalnet.hs @@ -0,0 +1,424 @@ +-- | Simple backend based on the TCP transport which offers node discovery +-- based on UDP multicast. This is a zero-configuration backend designed to +-- get you going with Cloud Haskell quickly without imposing any structure +-- on your application. +-- +-- To simplify getting started we provide special support for /master/ and +-- /slave/ nodes (see 'startSlave' and 'startMaster'). Use of these functions +-- is completely optional; you can use the local backend without making use +-- of the predefined master and slave nodes. +-- +-- [Minimal example] +-- +-- > import System.Environment (getArgs) +-- > import Control.Distributed.Process +-- > import Control.Distributed.Process.Node (initRemoteTable) +-- > import Control.Distributed.Process.Backend.SimpleLocalnet +-- > +-- > master :: Backend -> [NodeId] -> Process () +-- > master backend slaves = do +-- > -- Do something interesting with the slaves +-- > liftIO . putStrLn $ "Slaves: " ++ show slaves +-- > -- Terminate the slaves when the master terminates (this is optional) +-- > terminateAllSlaves backend +-- > +-- > main :: IO () +-- > main = do +-- > args <- getArgs +-- > +-- > case args of +-- > ["master", host, port] -> do +-- > backend <- initializeBackend host port initRemoteTable +-- > startMaster backend (master backend) +-- > ["slave", host, port] -> do +-- > backend <- initializeBackend host port initRemoteTable +-- > startSlave backend +-- +-- [Compiling and Running] +-- +-- Save to @example.hs@ and compile using +-- +-- > ghc -threaded example.hs +-- +-- Fire up some slave nodes (for the example, we run them on a single machine): +-- +-- > ./example slave localhost 8080 & +-- > ./example slave localhost 8081 & +-- > ./example slave localhost 8082 & +-- > ./example slave localhost 8083 & +-- +-- And start the master node: +-- +-- > ./example master localhost 8084 +-- +-- which should then output: +-- +-- > Slaves: [nid://localhost:8083:0,nid://localhost:8082:0,nid://localhost:8081:0,nid://localhost:8080:0] +-- +-- at which point the slaves should exit. +-- +-- To run the example on multiple machines, you could run +-- +-- > ./example slave 198.51.100.1 8080 & +-- > ./example slave 198.51.100.2 8080 & +-- > ./example slave 198.51.100.3 8080 & +-- > ./example slave 198.51.100.4 8080 & +-- +-- on four different machines (with IP addresses 198.51.100.1..4), and run the +-- master on a fifth node (or on any of the four machines that run the slave +-- nodes). +-- +-- It is important that every node has a unique (hostname, port number) pair, +-- and that the hostname you use to initialize the node can be resolved by +-- peer nodes. In other words, if you start a node and pass hostname @localhost@ +-- then peer nodes won't be able to reach it because @localhost@ will resolve +-- to a different IP address for them. +-- +-- [Troubleshooting] +-- +-- If you try the above example and the master process cannot find any slaves, +-- then it might be that your firewall settings do not allow for UDP multicast +-- (in particular, the default iptables on some Linux distributions might not +-- allow it). +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Control.Distributed.Process.Backend.SimpleLocalnet + ( -- * Initialization + Backend(..) + , initializeBackend + -- * Slave nodes + , startSlave + , terminateSlave + , findSlaves + , terminateAllSlaves + -- * Master nodes + , startMaster + ) where + +import System.IO (fixIO) +import Data.Maybe (catMaybes) +import Data.Binary (Binary(get, put), getWord8, putWord8) +import Data.Accessor (Accessor, accessor, (^:), (^.)) +import Data.Set (Set) +import qualified Data.Set as Set (insert, empty, toList) +import Data.Foldable (forM_) +import Data.Typeable (Typeable) +import Control.Exception (throw) +import Control.Monad (forever, replicateM, replicateM_) +import Control.Monad.Catch (bracket, try, finally) +import Control.Monad.IO.Class (liftIO) +import Control.Concurrent (forkIO, threadDelay, ThreadId) +import Control.Concurrent.MVar (MVar, newMVar, readMVar, modifyMVar_) +import Control.Distributed.Process + ( RemoteTable + , NodeId + , Process + , ProcessId + , WhereIsReply(..) + , whereis + , whereisRemoteAsync + , getSelfPid + , register + , reregister + , expect + , nsendRemote + , receiveWait + , match + , processNodeId + , monitorNode + , monitor + , unmonitor + , NodeMonitorNotification(..) + , ProcessRegistrationException + , newChan + , receiveChan + , nsend + , SendPort + , send + ) +import qualified Control.Distributed.Process.Node as Node + ( LocalNode + , newLocalNode + , localNodeId + , runProcess + ) +import qualified Network.Transport.TCP as NT + ( createTransport + , defaultTCPParameters + , TCPAddr(Addressable) + , TCPAddrInfo(TCPAddrInfo) + ) +import qualified Network.Transport as NT (Transport) +import qualified Network.Socket as N (HostName, ServiceName, SockAddr) +import Control.Distributed.Process.Backend.SimpleLocalnet.Internal.Multicast (initMulticast) + +-- | Local backend +data Backend = Backend { + -- | Create a new local node + newLocalNode :: IO Node.LocalNode + -- | @findPeers t@ broadcasts a /who's there?/ message on the local + -- network, waits 't' microseconds, and then collects and returns the answers. + -- You can use this to dynamically discover peer nodes. + , findPeers :: Int -> IO [NodeId] + -- | Make sure that all log messages are printed by the logger on the + -- current node + , redirectLogsHere :: [ProcessId] -> Process () + } + +data BackendState = BackendState { + _localNodes :: [Node.LocalNode] + , _peers :: Set NodeId + , discoveryDaemon :: ThreadId + } + +-- | Initialize the backend +initializeBackend :: N.HostName -> N.ServiceName -> RemoteTable -> IO Backend +initializeBackend host port rtable = do + mTransport <- NT.createTransport (NT.Addressable $ NT.TCPAddrInfo host port (\sn -> (host, sn))) + NT.defaultTCPParameters + (recv, sendp) <- initMulticast "224.0.0.99" 9999 1024 + (_, backendState) <- fixIO $ \ ~(tid, _) -> do + backendState <- newMVar BackendState + { _localNodes = [] + , _peers = Set.empty + , discoveryDaemon = tid + } + tid' <- forkIO $ peerDiscoveryDaemon backendState recv sendp + return (tid', backendState) + case mTransport of + Left err -> throw err + Right transport -> + let backend = Backend { + newLocalNode = apiNewLocalNode transport rtable backendState + , findPeers = apiFindPeers sendp backendState + , redirectLogsHere = apiRedirectLogsHere backend + } + in return backend + +-- | Create a new local node +apiNewLocalNode :: NT.Transport + -> RemoteTable + -> MVar BackendState + -> IO Node.LocalNode +apiNewLocalNode transport rtable backendState = do + localNode <- Node.newLocalNode transport rtable + modifyMVar_ backendState $ return . (localNodes ^: (localNode :)) + return localNode + +-- | Peer discovery +apiFindPeers :: (PeerDiscoveryMsg -> IO ()) + -> MVar BackendState + -> Int + -> IO [NodeId] +apiFindPeers sendfn backendState delay = do + sendfn PeerDiscoveryRequest + threadDelay delay + Set.toList . (^. peers) <$> readMVar backendState + +data PeerDiscoveryMsg = + PeerDiscoveryRequest + | PeerDiscoveryReply NodeId + +instance Binary PeerDiscoveryMsg where + put PeerDiscoveryRequest = putWord8 0 + put (PeerDiscoveryReply nid) = putWord8 1 >> put nid + get = do + header <- getWord8 + case header of + 0 -> return PeerDiscoveryRequest + 1 -> PeerDiscoveryReply <$> get + _ -> fail "PeerDiscoveryMsg.get: invalid" + +-- | Respond to peer discovery requests sent by other nodes +peerDiscoveryDaemon :: MVar BackendState + -> IO (PeerDiscoveryMsg, N.SockAddr) + -> (PeerDiscoveryMsg -> IO ()) + -> IO () +peerDiscoveryDaemon backendState recv sendfn = forever go + where + go = do + (msg, _) <- recv + case msg of + PeerDiscoveryRequest -> do + nodes <- (^. localNodes) <$> readMVar backendState + forM_ nodes $ sendfn . PeerDiscoveryReply . Node.localNodeId + PeerDiscoveryReply nid -> + modifyMVar_ backendState $ return . (peers ^: Set.insert nid) + +-------------------------------------------------------------------------------- +-- Back-end specific primitives -- +-------------------------------------------------------------------------------- + +-- | Make sure that all log messages are printed by the logger on this node +apiRedirectLogsHere :: Backend -> [ProcessId] -> Process () +apiRedirectLogsHere _backend slavecontrollers = do + mLogger <- whereis "logger" + myPid <- getSelfPid + + forM_ mLogger $ \logger -> do + bracket + (mapM monitor slavecontrollers) + (mapM unmonitor) + $ \_ -> do + + -- fire off redirect requests + forM_ slavecontrollers $ \pid -> send pid (RedirectLogsTo logger myPid) + + -- Wait for the replies + replicateM_ (length slavecontrollers) $ do + receiveWait + [ match (\(RedirectLogsReply {}) -> return ()) + , match (\(NodeMonitorNotification {}) -> return ()) + ] + +-------------------------------------------------------------------------------- +-- Slaves -- +-------------------------------------------------------------------------------- + +-- | Messages to slave nodes +-- +-- This datatype is not exposed; instead, we expose primitives for dealing +-- with slaves. +data SlaveControllerMsg + = SlaveTerminate + | RedirectLogsTo ProcessId ProcessId + deriving (Typeable, Show) + +instance Binary SlaveControllerMsg where + put SlaveTerminate = putWord8 0 + put (RedirectLogsTo a b) = do putWord8 1; put (a,b) + get = do + header <- getWord8 + case header of + 0 -> return SlaveTerminate + 1 -> do (a,b) <- get; return (RedirectLogsTo a b) + _ -> fail "SlaveControllerMsg.get: invalid" + +data RedirectLogsReply + = RedirectLogsReply ProcessId Bool + deriving (Typeable, Show) + +instance Binary RedirectLogsReply where + put (RedirectLogsReply from ok) = put (from,ok) + get = do + (from,ok) <- get + return (RedirectLogsReply from ok) + +-- | Calling 'slave' sets up a new local node and then waits. You start +-- processes on the slave by calling 'spawn' from other nodes. +-- +-- This function does not return. The only way to exit the slave is to CTRL-C +-- the process or call terminateSlave from another node. +startSlave :: Backend -> IO () +startSlave backend = do + node <- newLocalNode backend + Node.runProcess node slaveController + +-- | The slave controller interprets 'SlaveControllerMsg's +slaveController :: Process () +slaveController = do + pid <- getSelfPid + register "slaveController" pid + go + where + go = do + msg <- expect + case msg of + SlaveTerminate -> return () + RedirectLogsTo loggerPid from -> do + r <- try (reregister "logger" loggerPid) + ok <- case (r :: Either ProcessRegistrationException ()) of + Right _ -> return True + Left _ -> do + s <- try (register "logger" loggerPid) + case (s :: Either ProcessRegistrationException ()) of + Right _ -> return True + Left _ -> return False + pid <- getSelfPid + send from (RedirectLogsReply pid ok) + go + +-- | Terminate the slave at the given node ID +terminateSlave :: NodeId -> Process () +terminateSlave nid = nsendRemote nid "slaveController" SlaveTerminate + +-- | Find slave nodes +findSlaves :: Backend -> Process [ProcessId] +findSlaves backend = do + nodes <- liftIO $ findPeers backend 1000000 + -- Fire off asynchronous requests for the slave controller + + bracket + (mapM monitorNode nodes) + (mapM unmonitor) + $ \_ -> do + + -- fire off whereis requests + forM_ nodes $ \nid -> whereisRemoteAsync nid "slaveController" + + -- Wait for the replies + catMaybes <$> replicateM (length nodes) ( + receiveWait + [ match handleWhereIsReply + , match (\(NodeMonitorNotification {}) -> return Nothing) + ]) + where + handleWhereIsReply :: WhereIsReply -> Process (Maybe ProcessId) + handleWhereIsReply (WhereIsReply name mPid) + | name == "slaveController" = return mPid + | otherwise = return Nothing + +-- | Terminate all slaves +terminateAllSlaves :: Backend -> Process () +terminateAllSlaves backend = do + slaves <- findSlaves backend + forM_ slaves $ \pid -> send pid SlaveTerminate + liftIO $ threadDelay 1000000 + +-------------------------------------------------------------------------------- +-- Master nodes +-------------------------------------------------------------------------------- + +-- | 'startMaster' finds all slaves /currently/ available on the local network, +-- redirects all log messages to itself, and then calls the specified process, +-- passing the list of slaves nodes. +-- +-- Terminates when the specified process terminates. If you want to terminate +-- the slaves when the master terminates, you should manually call +-- 'terminateAllSlaves'. +-- +-- If you start more slave nodes after having started the master node, you can +-- discover them with later calls to 'findSlaves', but be aware that you will +-- need to call 'redirectLogHere' to redirect their logs to the master node. +-- +-- Note that you can use functionality of "SimpleLocalnet" directly (through +-- 'Backend'), instead of using 'startMaster'/'startSlave', if the master/slave +-- distinction does not suit your application. +startMaster :: Backend -> ([NodeId] -> Process ()) -> IO () +startMaster backend proc = do + node <- newLocalNode backend + Node.runProcess node $ do + slaves <- findSlaves backend + redirectLogsHere backend slaves + proc (map processNodeId slaves) `finally` shutdownLogger + +-- +-- | shut down the logger process. This ensures that any pending +-- messages are flushed before the process exits. +-- +shutdownLogger :: Process () +shutdownLogger = do + (sport,rport) <- newChan + nsend "logger" (sport :: SendPort ()) + receiveChan rport + -- TODO: we should monitor the logger process so we don't deadlock if + -- it has already died. + +-------------------------------------------------------------------------------- +-- Accessors -- +-------------------------------------------------------------------------------- + +localNodes :: Accessor BackendState [Node.LocalNode] +localNodes = accessor _localNodes (\ns st -> st { _localNodes = ns }) + +peers :: Accessor BackendState (Set NodeId) +peers = accessor _peers (\ps st -> st { _peers = ps }) diff --git a/packages/distributed-process-simplelocalnet/src/Control/Distributed/Process/Backend/SimpleLocalnet/Internal/Multicast.hs b/packages/distributed-process-simplelocalnet/src/Control/Distributed/Process/Backend/SimpleLocalnet/Internal/Multicast.hs new file mode 100644 index 00000000..e6f25a06 --- /dev/null +++ b/packages/distributed-process-simplelocalnet/src/Control/Distributed/Process/Backend/SimpleLocalnet/Internal/Multicast.hs @@ -0,0 +1,120 @@ +-- | Multicast utilities +{-# LANGUAGE RankNTypes #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Control.Distributed.Process.Backend.SimpleLocalnet.Internal.Multicast (initMulticast) where + +import Data.Map (Map) +import qualified Data.Map as Map (empty) +import Data.Binary (Binary, decode, encode) +import Data.IORef (IORef, newIORef, readIORef, modifyIORef) +import qualified Data.ByteString as BSS (ByteString, concat) +import qualified Data.ByteString.Lazy as BSL + ( ByteString + , empty + , append + , fromChunks + , toChunks + , length + , splitAt + ) +import Data.Accessor (Accessor, (^:), (^.), (^=)) +import qualified Data.Accessor.Container as DAC (mapDefault) +import Network.Socket (HostName, PortNumber, Socket, SockAddr) +import qualified Network.Socket.ByteString as NBS (recvFrom, sendManyTo) +import Network.Transport.Internal (decodeNum32, encodeEnum32) +import Network.Multicast (multicastSender, multicastReceiver) + +-------------------------------------------------------------------------------- +-- Top-level API -- +-------------------------------------------------------------------------------- + +-- | Given a hostname and a port number, initialize the multicast system. +-- +-- Note: it is important that you never send messages larger than the maximum +-- message size; if you do, all subsequent communication will probably fail. +-- +-- Returns a reader and a writer. +-- +-- NOTE: By rights the two functions should be "locally" polymorphic in 'a', +-- but this requires impredicative types. +initMulticast :: forall a. Binary a + => HostName -- ^ Multicast IP + -> PortNumber -- ^ Port number + -> Int -- ^ Maximum message size + -> IO (IO (a, SockAddr), a -> IO ()) +initMulticast host port bufferSize = do + (sendSock, sendAddr) <- multicastSender host port + readSock <- multicastReceiver host port + st <- newIORef Map.empty + return (recvBinary readSock st bufferSize, writer sendSock sendAddr) + where + writer :: forall a. Binary a => Socket -> SockAddr -> a -> IO () + writer sock addr val = do + let bytes = encode val + len = encodeEnum32 (BSL.length bytes) + NBS.sendManyTo sock (len : BSL.toChunks bytes) addr + +-------------------------------------------------------------------------------- +-- UDP multicast read, dealing with multiple senders -- +-------------------------------------------------------------------------------- + +type UDPState = Map SockAddr BSL.ByteString + +bufferFor :: SockAddr -> Accessor UDPState BSL.ByteString +bufferFor = DAC.mapDefault BSL.empty + +bufferAppend :: SockAddr -> BSS.ByteString -> UDPState -> UDPState +bufferAppend addr bytes = + bufferFor addr ^: flip BSL.append (BSL.fromChunks [bytes]) + +recvBinary :: Binary a => Socket -> IORef UDPState -> Int -> IO (a, SockAddr) +recvBinary sock st bufferSize = do + (bytes, addr) <- recvWithLength sock st bufferSize + return (decode bytes, addr) + +recvWithLength :: Socket + -> IORef UDPState + -> Int + -> IO (BSL.ByteString, SockAddr) +recvWithLength sock st bufferSize = do + (len, addr) <- recvExact sock 4 st bufferSize + let n = decodeNum32 . BSS.concat . BSL.toChunks $ len + bytes <- recvExactFrom addr sock n st bufferSize + return (bytes, addr) + +-- Receive all bytes currently in the buffer +recvAll :: Socket -> IORef UDPState -> Int -> IO SockAddr +recvAll sock st bufferSize = do + (bytes, addr) <- NBS.recvFrom sock bufferSize + modifyIORef st $ bufferAppend addr bytes + return addr + +recvExact :: Socket + -> Int + -> IORef UDPState + -> Int + -> IO (BSL.ByteString, SockAddr) +recvExact sock n st bufferSize = do + addr <- recvAll sock st bufferSize + bytes <- recvExactFrom addr sock n st bufferSize + return (bytes, addr) + +recvExactFrom :: SockAddr + -> Socket + -> Int + -> IORef UDPState + -> Int + -> IO BSL.ByteString +recvExactFrom addr sock n st bufferSize = go + where + go :: IO BSL.ByteString + go = do + accAddr <- (^. bufferFor addr) <$> readIORef st + if BSL.length accAddr >= fromIntegral n + then do + let (bytes, accAddr') = BSL.splitAt (fromIntegral n) accAddr + modifyIORef st $ bufferFor addr ^= accAddr' + return bytes + else do + _ <- recvAll sock st bufferSize + go diff --git a/packages/distributed-process-simplelocalnet/tests/Main.hs b/packages/distributed-process-simplelocalnet/tests/Main.hs new file mode 100644 index 00000000..dd13e663 --- /dev/null +++ b/packages/distributed-process-simplelocalnet/tests/Main.hs @@ -0,0 +1,44 @@ + + +import Control.Concurrent (forkIO, threadDelay) +import qualified Control.Concurrent.MVar as MVar +import Control.Distributed.Process (NodeId, Process, liftIO) +import Control.Distributed.Process.Node (initRemoteTable) +import Control.Distributed.Process.Backend.SimpleLocalnet +import Control.Monad (forM_) +import qualified Data.List as List +import Test.Tasty (TestTree, defaultMain, testGroup) +import Test.Tasty.HUnit (assertEqual, testCase) + +main :: IO () +main = defaultMain + $ testGroup "Test suite" + [ testDiscoverNodes + ] + +testDiscoverNodes :: TestTree +testDiscoverNodes = testCase "discover nodes" $ do + + -- Initialize slave nodes + forM_ ["10000", "10001", "10002", "10003"] $ \port -> do + backend <- initializeBackend "127.0.0.1" port initRemoteTable + _ <- forkIO $ startSlave backend + threadDelay 100000 + + -- initialize master node + discoveredNodesSlot <- MVar.newEmptyMVar + backend <- initializeBackend "127.0.0.1" "10004" initRemoteTable + startMaster backend $ \nds -> do + terminateAllSlaves backend + liftIO $ MVar.putMVar discoveredNodesSlot nds + + discoveredNodes <- (List.sort . List.nub) <$> MVar.readMVar discoveredNodesSlot + assertEqual "Discovered nodes" + [ "nid://127.0.0.1:10000:0" + , "nid://127.0.0.1:10001:0" + , "nid://127.0.0.1:10002:0" + , "nid://127.0.0.1:10003:0" + ] + (map show discoveredNodes) + + diff --git a/packages/distributed-process-supervisor/ChangeLog b/packages/distributed-process-supervisor/ChangeLog new file mode 100644 index 00000000..b9595243 --- /dev/null +++ b/packages/distributed-process-supervisor/ChangeLog @@ -0,0 +1,21 @@ +2018-06-14 Facundo Domínguez 0.2.1 + +* Update dependency bounds. + +2016-02-16 Facundo Domínguez 0.1.3.2 + +* Update dependency bounds. + +2015-06-15 Facundo Domínguez 0.1.3 + +* Add compatibility with ghc-7.10. +* Fix dependency bounds. + +# HEAD + +* Added initial GenServer module +* Added Timer Module +* Moved time functions into Time.hs +* Added Async API +* Added GenProcess API (subsumes lower level GenServer API) + diff --git a/packages/distributed-process-supervisor/LICENSE b/packages/distributed-process-supervisor/LICENSE new file mode 100644 index 00000000..f7a8c56f --- /dev/null +++ b/packages/distributed-process-supervisor/LICENSE @@ -0,0 +1,30 @@ +Copyright Tim Watson, 2012-2013. + +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. diff --git a/packages/distributed-process-supervisor/distributed-process-supervisor.cabal b/packages/distributed-process-supervisor/distributed-process-supervisor.cabal new file mode 100644 index 00000000..427990d9 --- /dev/null +++ b/packages/distributed-process-supervisor/distributed-process-supervisor.cabal @@ -0,0 +1,144 @@ +cabal-version: 3.0 +name: distributed-process-supervisor +version: 0.2.1 +build-type: Simple +license: BSD-3-Clause +license-file: LICENSE +Copyright: Tim Watson 2012 - 2013 +Author: Tim Watson +maintainer: The Distributed Haskell team +Stability: experimental +Homepage: http://github.com/haskell-distributed/distributed-process-supervisor +Bug-Reports: http://github.com/haskell-distributed/distributed-process-supervisor/issues +synopsis: Supervisors for The Cloud Haskell Application Platform +description: A part of the Cloud Haskell framework + + This package implements a process which supervises a set of other processes, referred to as its children. + These child processes can be either workers (i.e., processes that do something useful in your application) + or other supervisors. In this way, supervisors may be used to build a hierarchical process structure + called a supervision tree, which provides a convenient structure for building fault tolerant software. + + For detailed information see "Control.Distributed.Process.Supervisor" +category: Control +tested-with: GHC==8.10.7 GHC==9.0.2 GHC==9.2.8 GHC==9.4.5 GHC==9.6.4 GHC==9.8.2 GHC==9.10.1 +extra-source-files: ChangeLog + +source-repository head + type: git + location: https://github.com/haskell-distributed/distributed-process-supervisor + +common warnings + ghc-options: -Wall + -Wcompat + -Widentities + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wredundant-constraints + -fhide-source-paths + -Wpartial-fields + +library + import: warnings + build-depends: + base >= 4.14 && < 5, + bytestring >= 0.10, + data-accessor >= 0.2.2.3, + distributed-static >= 0.3.4.0 && < 0.4, + distributed-process >= 0.7.3 && < 0.8, + distributed-process-extras >= 0.3.1 && < 0.4, + distributed-process-client-server >= 0.2.0 && < 0.4, + binary >= 0.8 && < 0.9, + deepseq >= 1.4 && < 1.6, + mtl, + containers >= 0.6 && < 0.8, + hashable >= 1.2.0.5 && < 1.6, + unordered-containers >= 0.2.3.0 && < 0.3, + fingertree < 0.2, + stm >= 2.4 && < 2.6, + time > 1.4 && < 1.15, + transformers, + exceptions >= 0.10 && < 0.11 + hs-source-dirs: src + exposed-modules: + Control.Distributed.Process.Supervisor + Control.Distributed.Process.Supervisor.Management + other-modules: + Control.Distributed.Process.Supervisor.Types + +test-suite SupervisorTests + import: warnings + type: exitcode-stdio-1.0 + build-depends: + base >= 4.14 && < 5, + ansi-terminal >= 0.5 && < 0.9, + containers, + unordered-containers, + hashable, + distributed-static >= 0.3.5.0 && < 0.4, + distributed-process >= 0.7.3 && < 0.8, + distributed-process-supervisor, + distributed-process-extras >= 0.3 && < 0.4, + distributed-process-client-server, + distributed-static, + bytestring, + random, + data-accessor, + fingertree < 0.2, + network-transport >= 0.4 && < 0.6, + mtl, + network-transport-tcp >= 0.4 && < 0.9, + binary >= 0.8 && < 0.9, + deepseq, + network >= 2.3 && < 3.3, + HUnit >= 1.2 && < 2, + stm, + time, + test-framework >= 0.6 && < 0.9, + test-framework-hunit, + transformers, + rematch >= 0.2.0.0, + ghc-prim, + exceptions >= 0.10 && < 0.11 + hs-source-dirs: tests + ghc-options: -threaded -rtsopts -with-rtsopts=-N -fno-warn-name-shadowing -fno-warn-unused-do-bind -eventlog + main-is: TestSupervisor.hs + other-modules: TestUtils + +test-suite NonThreadedSupervisorTests + import: warnings + type: exitcode-stdio-1.0 + build-depends: + base >= 4.14 && < 5, + ansi-terminal >= 0.5 && < 0.9, + containers, + unordered-containers, + hashable, + distributed-static >= 0.3.5.0 && < 0.4, + distributed-process >= 0.7.3 && < 0.8, + distributed-process-supervisor, + distributed-process-extras, + distributed-process-client-server, + distributed-static, + bytestring, + random, + data-accessor, + fingertree < 0.2, + network-transport, + mtl, + network-transport-tcp >= 0.4 && < 0.9, + binary >= 0.8 && < 0.9, + deepseq, + network >= 2.3 && < 3.3, + HUnit >= 1.2 && < 2, + stm, + time, + test-framework >= 0.6 && < 0.9, + test-framework-hunit, + transformers, + rematch >= 0.2.0.0, + ghc-prim, + exceptions >= 0.10 && < 0.11 + hs-source-dirs: tests + ghc-options: -rtsopts -fno-warn-unused-do-bind -fno-warn-name-shadowing + main-is: TestSupervisor.hs + other-modules: TestUtils diff --git a/packages/distributed-process-supervisor/src/Control/Distributed/Process/Supervisor.hs b/packages/distributed-process-supervisor/src/Control/Distributed/Process/Supervisor.hs new file mode 100644 index 00000000..c32b07b0 --- /dev/null +++ b/packages/distributed-process-supervisor/src/Control/Distributed/Process/Supervisor.hs @@ -0,0 +1,1645 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Distributed.Process.Supervisor +-- Copyright : (c) Tim Watson 2012 - 2013 +-- License : BSD3 (see the file LICENSE) +-- +-- Maintainer : Tim Watson +-- Stability : experimental +-- Portability : non-portable (requires concurrency) +-- +-- This module implements a process which supervises a set of other +-- processes, referred to as its children. These /child processes/ can be +-- either workers (i.e., processes that do something useful in your application) +-- or other supervisors. In this way, supervisors may be used to build a +-- hierarchical process structure called a supervision tree, which provides +-- a convenient structure for building fault tolerant software. +-- +-- Unless otherwise stated, all client functions in this module will cause the +-- calling process to exit unless the specified supervisor process can be resolved. +-- +-- [Supervision Principles] +-- +-- A supervisor is responsible for starting, stopping and monitoring its child +-- processes so as to keep them alive by restarting them when necessary. +-- +-- The supervisor's children are defined as a list of child specifications +-- (see "ChildSpec"). When a supervisor is started, its children are started +-- in left-to-right (insertion order) according to this list. When a supervisor +-- stops (or exits for any reason), it will stop all its children before exiting. +-- Child specs can be added to the supervisor after it has started, either on +-- the left or right of the existing list of child specs. +-- +-- [Restart Strategies] +-- +-- Supervisors are initialised with a 'RestartStrategy', which describes how +-- the supervisor should respond to a child that exits and should be restarted +-- (see below for the rules governing child restart eligibility). Each restart +-- strategy comprises a 'RestartMode' and 'RestartLimit', which govern how +-- the restart should be handled, and the point at which the supervisor +-- should give up and stop itself respectively. +-- +-- With the exception of the @RestartOne@ strategy, which indicates that the +-- supervisor will restart /only/ the one individual failing child, each +-- strategy describes a way to select the set of children that should be +-- restarted if /any/ child fails. The @RestartAll@ strategy, as its name +-- suggests, selects /all/ children, whilst the @RestartLeft@ and @RestartRight@ +-- strategies select /all/ children to the left or right of the failed child, +-- in insertion (i.e., startup) order. +-- +-- Note that a /branch/ restart will only occur if the child that exited is +-- meant to be restarted. Since @Temporary@ children are never restarted and +-- @Transient@ children are /not/ restarted if they exit normally, in both these +-- circumstances we leave the remaining supervised children alone. Otherwise, +-- the failing child is /always/ included in the /branch/ to be restarted. +-- +-- For a hypothetical set of children @a@ through @d@, the following pseudocode +-- demonstrates how the restart strategies work. +-- +-- > let children = [a..d] +-- > let failure = c +-- > restartsFor RestartOne children failure = [c] +-- > restartsFor RestartAll children failure = [a,b,c,d] +-- > restartsFor RestartLeft children failure = [a,b,c] +-- > restartsFor RestartRight children failure = [c,d] +-- +-- [Branch Restarts] +-- +-- We refer to a restart (strategy) that involves a set of children as a +-- /branch restart/ from now on. The behaviour of branch restarts can be further +-- refined by the 'RestartMode' with which a 'RestartStrategy' is parameterised. +-- The @RestartEach@ mode treats each child sequentially, first stopping the +-- respective child process and then restarting it. Each child is stopped and +-- started fully before moving on to the next, as the following imaginary +-- example demonstrates for children @[a,b,c]@: +-- +-- > stop a +-- > start a +-- > stop b +-- > start b +-- > stop c +-- > start c +-- +-- By contrast, @RestartInOrder@ will first run through the selected list of +-- children, stopping them. Then, once all the children have been stopped, it +-- will make a second pass, to handle (re)starting them. No child is started +-- until all children have been stopped, as the following imaginary example +-- demonstrates: +-- +-- > stop a +-- > stop b +-- > stop c +-- > start a +-- > start b +-- > start c +-- +-- Both the previous examples have shown children being stopped and started +-- from left to right, but that is up to the user. The 'RestartMode' data +-- type's constructors take a 'RestartOrder', which determines whether the +-- selected children will be processed from @LeftToRight@ or @RightToLeft@. +-- +-- Sometimes it is desireable to stop children in one order and start them +-- in the opposite. This is typically the case when children are in some +-- way dependent on one another, such that restarting them in the wrong order +-- might cause the system to misbehave. For this scenarios, there is another +-- 'RestartMode' that will shut children down in the given order, but then +-- restarts them in the reverse. Using @RestartRevOrder@ mode, if we have +-- children @[a,b,c]@ such that @b@ depends on @a@ and @c@ on @b@, we can stop +-- them in the reverse of their startup order, but restart them the other way +-- around like so: +-- +-- > RestartRevOrder RightToLeft +-- +-- The effect will be thus: +-- +-- > stop c +-- > stop b +-- > stop a +-- > start a +-- > start b +-- > start c +-- +-- [Restart Intensity Limits] +-- +-- If a child process repeatedly crashes during (or shortly after) starting, +-- it is possible for the supervisor to get stuck in an endless loop of +-- restarts. In order prevent this, each restart strategy is parameterised +-- with a 'RestartLimit' that caps the number of restarts allowed within a +-- specific time period. If the supervisor exceeds this limit, it will stop, +-- stopping all its children (in left-to-right order) and exit with the +-- reason @ExitOther "ReachedMaxRestartIntensity"@. +-- +-- The 'MaxRestarts' type is a positive integer, and together with a specified +-- @TimeInterval@ forms the 'RestartLimit' to which the supervisor will adhere. +-- Since a great many children can be restarted in close succession when +-- a /branch restart/ occurs (as a result of @RestartAll@, @RestartLeft@ or +-- @RestartRight@ being triggered), the supervisor will track the operation +-- as a single restart attempt, since otherwise it would likely exceed its +-- maximum restart intensity too quickly. +-- +-- [Child Restart and Stop Policies] +-- +-- When the supervisor detects that a child has died, the 'RestartPolicy' +-- configured in the child specification is used to determin what to do. If +-- the this is set to @Permanent@, then the child is always restarted. +-- If it is @Temporary@, then the child is never restarted and the child +-- specification is removed from the supervisor. A @Transient@ child will +-- be restarted only if it exits /abnormally/, otherwise it is left +-- inactive (but its specification is left in place). Finally, an @Intrinsic@ +-- child is treated like a @Transient@ one, except that if /this/ kind of child +-- exits /normally/, then the supervisor will also exit normally. +-- +-- When the supervisor does stop a child process, the "ChildStopPolicy" +-- provided with the 'ChildSpec' determines how the supervisor should go +-- about doing so. If this is "StopImmediately", then the child will +-- be killed without further notice, which means the child will /not/ have +-- an opportunity to clean up any internal state and/or release any held +-- resources. If the policy is @StopTimeout delay@ however, the child +-- will be sent an /exit signal/ instead, i.e., the supervisor will cause +-- the child to exit via @exit childPid ExitShutdown@, and then will wait +-- until the given @delay@ for the child to exit normally. If this does not +-- happen within the given delay, the supervisor will revert to the more +-- aggressive "StopImmediately" policy and try again. Any errors that +-- occur during a timed-out shutdown will be logged, however exit reasons +-- resulting from "StopImmediately" are ignored. +-- +-- [Creating Child Specs] +-- +-- The 'ToChildStart' typeclass simplifies the process of defining a 'ChildStart' +-- providing two default instances from which a 'ChildStart' datum can be +-- generated. The first, takes a @Closure (Process ())@, where the enclosed +-- action (in the @Process@ monad) is the actual (long running) code that we +-- wish to supervise. In the case of a /managed process/, this is usually the +-- server loop, constructed by evaluating some variant of @ManagedProcess.serve@. +-- +-- The second instance supports returning a /handle/ which can contain extra +-- data about the child process - usually this is a newtype wrapper used by +-- clients to communicate with the process. +-- +-- When the supervisor spawns its child processes, they should be linked to their +-- parent (i.e., the supervisor), such that even if the supervisor is killed +-- abruptly by an asynchronous exception, the children will still be taken down +-- with it, though somewhat less ceremoniously in that case. This behaviour is +-- injected by the supervisor for any "ChildStart" built on @Closure (Process ())@ +-- automatically, but the /handle/ based approach requires that the @Closure@ +-- responsible for spawning does the linking itself. +-- +-- Finally, we provide a simple shortcut to @staticClosure@, for consumers +-- who've manually registered with the /remote table/ and don't with to use +-- tempate haskell (e.g. users of the Explicit closures API). +-- +-- [Supervision Trees & Supervisor Shutdown] +-- +-- To create a supervision tree, one simply adds supervisors below one another +-- as children, setting the @childType@ field of their 'ChildSpec' to +-- @Supervisor@ instead of @Worker@. Supervision tree can be arbitrarilly +-- deep, and it is for this reason that we recommend giving a @Supervisor@ child +-- an arbitrary length of time to stop, by setting the delay to @Infinity@ +-- or a very large @TimeInterval@. +-- +----------------------------------------------------------------------------- + +module Control.Distributed.Process.Supervisor + ( -- * Defining and Running a Supervisor + ChildSpec(..) + , ChildKey + , ChildType(..) + , ChildStopPolicy(..) + , ChildStart(..) + , RegisteredName(LocalName, CustomRegister) + , RestartPolicy(..) +-- , ChildRestart(..) + , ChildRef(..) + , isRunning + , isRestarting + , Child + , StaticLabel + , SupervisorPid + , ChildPid + , ToChildStart(..) + , start + , run + -- * Limits and Defaults + , MaxRestarts + , maxRestarts + , RestartLimit(..) + , limit + , defaultLimits + , RestartMode(..) + , RestartOrder(..) + , RestartStrategy(..) + , ShutdownMode(..) + , restartOne + , restartAll + , restartLeft + , restartRight + -- * Adding and Removing Children + , addChild + , AddChildResult(..) + , StartChildResult(..) + , startChild + , startNewChild + , stopChild + , StopChildResult(..) + , deleteChild + , DeleteChildResult(..) + , restartChild + , RestartChildResult(..) + -- * Normative Shutdown + , shutdown + , shutdownAndWait + -- * Queries and Statistics + , lookupChild + , listChildren + , SupervisorStats(..) + , statistics + , getRestartIntensity + , definedChildren + , definedWorkers + , definedSupervisors + , runningChildren + , runningWorkers + , runningSupervisors + -- * Additional (Misc) Types + , StartFailure(..) + , ChildInitFailure(..) + ) where + +import Control.DeepSeq (NFData) + +import Control.Distributed.Process.Supervisor.Types +import Control.Distributed.Process + ( Process + , ProcessId + , MonitorRef + , DiedReason(..) + , Match + , Handler(..) + , Message + , ProcessMonitorNotification(..) + , Closure + , Static + , exit + , kill + , match + , matchIf + , monitor + , getSelfPid + , liftIO + , catchExit + , catchesExit + , catches + , die + , link + , send + , register + , spawnLocal + , unsafeWrapMessage + , unmonitor + , withMonitor_ + , expect + , unClosure + , receiveWait + , receiveTimeout + , handleMessageIf + ) +import Control.Distributed.Process.Management (mxNotify, MxEvent(MxUser)) +import Control.Distributed.Process.Extras.Internal.Primitives hiding (monitor) +import Control.Distributed.Process.Extras.Internal.Types + ( ExitReason(..) + ) +import Control.Distributed.Process.ManagedProcess + ( handleCall + , handleInfo + , reply + , continue + , stop + , stopWith + , input + , defaultProcess + , prioritised + , InitHandler + , InitResult(..) + , ProcessAction + , ProcessReply + , ProcessDefinition(..) + , PrioritisedProcessDefinition(..) + , Priority() + , DispatchPriority + , UnhandledMessagePolicy(Drop) + , ExitState + , exitState + ) +import qualified Control.Distributed.Process.ManagedProcess.UnsafeClient as Unsafe + ( call + , cast + ) +import qualified Control.Distributed.Process.ManagedProcess as MP + ( pserve + ) +import Control.Distributed.Process.ManagedProcess.Server.Priority + ( prioritiseCast_ + , prioritiseCall_ + , prioritiseInfo_ + , setPriority + , evalAfter + ) +import Control.Distributed.Process.ManagedProcess.Server.Restricted + ( RestrictedProcess + , Result + , RestrictedAction + , getState + , putState + ) +import qualified Control.Distributed.Process.ManagedProcess.Server.Restricted as Restricted + ( handleCallIf + , handleCall + , handleCast + , reply + , continue + ) +import Control.Distributed.Process.Extras.SystemLog + ( LogClient + , LogChan + , LogText + , Logger(..) + ) +import qualified Control.Distributed.Process.Extras.SystemLog as Log +import Control.Distributed.Process.Extras.Time +import Control.Distributed.Static + ( staticClosure + ) +import Control.Exception (SomeException, throwIO) +import Control.Monad.Catch (catch, finally, mask) +import Control.Monad (void, forM) + +import Data.Accessor + ( Accessor + , accessor + , (^:) + , (.>) + , (^=) + , (^.) + ) +import Data.Binary (Binary) +import Data.Foldable (find, foldlM, toList) +import Data.List (foldl') +import qualified Data.List as List (lookup) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Sequence + ( Seq + , ViewL(EmptyL, (:<)) + , ViewR(EmptyR, (:>)) + , (<|) + , (|>) + , (><) + , filter) +import qualified Data.Sequence as Seq +import Data.Time.Clock + ( NominalDiffTime + , UTCTime + , getCurrentTime + , diffUTCTime + ) +import Data.Typeable (Typeable) + +import Prelude hiding (filter, init, rem) + +import GHC.Generics + +-------------------------------------------------------------------------------- +-- Types -- +-------------------------------------------------------------------------------- + +-- TODO: ToChildStart belongs with rest of types in +-- Control.Distributed.Process.Supervisor.Types + +-- | A type that can be converted to a 'ChildStart'. +class ToChildStart a where + toChildStart :: a -> Process ChildStart + +instance ToChildStart (Closure (Process ())) where + toChildStart = return . RunClosure + +instance ToChildStart (Closure (SupervisorPid -> Process (ChildPid, Message))) where + toChildStart = return . CreateHandle + +instance ToChildStart (Static (Process ())) where + toChildStart = toChildStart . staticClosure + +-- internal APIs. The corresponding XxxResult types are in +-- Control.Distributed.Process.Supervisor.Types + +data DeleteChild = DeleteChild !ChildKey + deriving (Typeable, Generic) +instance Binary DeleteChild where +instance NFData DeleteChild where + +data FindReq = FindReq ChildKey + deriving (Typeable, Generic) +instance Binary FindReq where +instance NFData FindReq where + +data StatsReq = StatsReq + deriving (Typeable, Generic) +instance Binary StatsReq where +instance NFData StatsReq where + +data ListReq = ListReq + deriving (Typeable, Generic) +instance Binary ListReq where +instance NFData ListReq where + +type ImmediateStart = Bool + +data AddChildReq = AddChild !ImmediateStart !ChildSpec + deriving (Typeable, Generic, Show) +instance Binary AddChildReq where +instance NFData AddChildReq where + +data AddChildRes = Exists ChildRef | Added State + +data StartChildReq = StartChild !ChildKey + deriving (Typeable, Generic) +instance Binary StartChildReq where +instance NFData StartChildReq where + +data RestartChildReq = RestartChildReq !ChildKey + deriving (Typeable, Generic, Show, Eq) +instance Binary RestartChildReq where +instance NFData RestartChildReq where + +data DelayedRestart = DelayedRestart !ChildKey !DiedReason + deriving (Typeable, Generic, Show, Eq) +instance Binary DelayedRestart where +instance NFData DelayedRestart + +data StopChildReq = StopChildReq !ChildKey + deriving (Typeable, Generic, Show, Eq) +instance Binary StopChildReq where +instance NFData StopChildReq where + +data IgnoreChildReq = IgnoreChildReq !ChildPid + deriving (Typeable, Generic) +instance Binary IgnoreChildReq where +instance NFData IgnoreChildReq where + +type ChildSpecs = Seq Child +type Prefix = ChildSpecs +type Suffix = ChildSpecs + +data StatsType = Active | Specified + +data LogSink = LogProcess !LogClient | LogChan + +instance Logger LogSink where + logMessage LogChan = logMessage Log.logChannel + logMessage (LogProcess client') = logMessage client' + +data State = State { + _specs :: ChildSpecs + , _active :: Map ChildPid ChildKey + , _strategy :: RestartStrategy + , _restartPeriod :: NominalDiffTime + , _restarts :: [UTCTime] + , _stats :: SupervisorStats + , _logger :: LogSink + , shutdownStrategy :: ShutdownMode + } + +supErrId :: String -> String +supErrId s = "Control.Distributed.Process" ++ s + +-------------------------------------------------------------------------------- +-- Starting/Running Supervisor -- +-------------------------------------------------------------------------------- + +-- | Start a supervisor (process), running the supplied children and restart +-- strategy. +-- +-- > start = spawnLocal . run +-- +start :: RestartStrategy -> ShutdownMode -> [ChildSpec] -> Process SupervisorPid +start rs ss cs = spawnLocal $ run rs ss cs + +-- | Run the supplied children using the provided restart strategy. +-- +run :: RestartStrategy -> ShutdownMode -> [ChildSpec] -> Process () +run rs ss specs' = MP.pserve (rs, ss, specs') supInit serverDefinition + +-------------------------------------------------------------------------------- +-- Client Facing API -- +-------------------------------------------------------------------------------- + +-- | Obtain statistics about a running supervisor. +-- +statistics :: Addressable a => a -> Process (SupervisorStats) +statistics = (flip Unsafe.call) StatsReq + +-- | Lookup a possibly supervised child, given its 'ChildKey'. +-- +lookupChild :: Addressable a => a -> ChildKey -> Process (Maybe (ChildRef, ChildSpec)) +lookupChild addr key = Unsafe.call addr $ FindReq key + +-- | List all know (i.e., configured) children. +-- +listChildren :: Addressable a => a -> Process [Child] +listChildren addr = Unsafe.call addr ListReq + +-- | Add a new child. +-- +addChild :: Addressable a => a -> ChildSpec -> Process AddChildResult +addChild addr spec = Unsafe.call addr $ AddChild False spec + +-- | Start an existing (configured) child. The 'ChildSpec' must already be +-- present (see 'addChild'), otherwise the operation will fail. +-- +startChild :: Addressable a => a -> ChildKey -> Process StartChildResult +startChild addr key = Unsafe.call addr $ StartChild key + +-- | Atomically add and start a new child spec. Will fail if a child with +-- the given key is already present. +-- +startNewChild :: Addressable a + => a + -> ChildSpec + -> Process AddChildResult +startNewChild addr spec = Unsafe.call addr $ AddChild True spec + +-- | Delete a supervised child. The child must already be stopped (see +-- 'stopChild'). +-- +deleteChild :: Addressable a => a -> ChildKey -> Process DeleteChildResult +deleteChild sid childKey = Unsafe.call sid $ DeleteChild childKey + +-- | Stop a running child. +-- +stopChild :: Addressable a + => a + -> ChildKey + -> Process StopChildResult +stopChild sid = Unsafe.call sid . StopChildReq + +-- | Forcibly restart a running child. +-- +restartChild :: Addressable a + => a + -> ChildKey + -> Process RestartChildResult +restartChild sid = Unsafe.call sid . RestartChildReq + +-- | Gracefully stop/shutdown a running supervisor. Returns immediately if the +-- /address/ cannot be resolved. +-- +shutdown :: Resolvable a => a -> Process () +shutdown sid = do + mPid <- resolve sid + case mPid of + Nothing -> return () + Just p -> exit p ExitShutdown + +-- | As 'shutdown', but waits until the supervisor process has exited, at which +-- point the caller can be sure that all children have also stopped. Returns +-- immediately if the /address/ cannot be resolved. +-- +shutdownAndWait :: Resolvable a => a -> Process () +shutdownAndWait sid = do + mPid <- resolve sid + case mPid of + Nothing -> return () + Just p -> withMonitor_ p $ do + shutdown p + receiveWait [ matchIf (\(ProcessMonitorNotification _ p' _) -> p' == p) + (\_ -> return ()) + ] + +-------------------------------------------------------------------------------- +-- Server Initialisation/Startup -- +-------------------------------------------------------------------------------- + +supInit :: InitHandler (RestartStrategy, ShutdownMode, [ChildSpec]) State +supInit (strategy', shutdown', specs') = do + logClient <- Log.client + let client' = case logClient of + Nothing -> LogChan + Just c -> LogProcess c + let initState = ( ( -- as a NominalDiffTime (in seconds) + restartPeriod ^= configuredRestartPeriod + ) + . (strategy ^= strategy') + . (logger ^= client') + $ emptyState shutdown' + ) + -- TODO: should we return Ignore, as per OTP's supervisor, if no child starts? + catch (foldlM initChild initState specs' >>= return . (flip InitOk) Infinity) + (\(e :: SomeException) -> do + sup <- getSelfPid + logEntry Log.error $ + mkReport "Could not init supervisor " sup "noproc" (show e) + return $ InitStop (show e)) + where + initChild :: State -> ChildSpec -> Process State + initChild st ch = + case (findChild (childKey ch) st) of + Just (ref, _) -> die $ StartFailureDuplicateChild ref + Nothing -> tryStartChild ch >>= initialised st ch + + configuredRestartPeriod = + let maxT' = maxT (intensity strategy') + tI = asTimeout maxT' + tMs = (fromIntegral tI * (0.000001 :: Float)) + in fromRational (toRational tMs) :: NominalDiffTime + +initialised :: State + -> ChildSpec + -> Either StartFailure ChildRef + -> Process State +initialised _ _ (Left err) = liftIO $ throwIO $ ChildInitFailure (show err) +initialised state spec (Right ref) = do + mPid <- resolve ref + case mPid of + Nothing -> die $ (supErrId ".initChild:child=") ++ (childKey spec) ++ ":InvalidChildRef" + Just childPid -> do + return $ ( (active ^: Map.insert childPid chId) + . (specs ^: (|> (ref, spec))) + $ bumpStats Active chType (+1) state + ) + where chId = childKey spec + chType = childType spec + +-------------------------------------------------------------------------------- +-- Server Definition/State -- +-------------------------------------------------------------------------------- + +emptyState :: ShutdownMode -> State +emptyState strat = State { + _specs = Seq.empty + , _active = Map.empty + , _strategy = restartAll + , _restartPeriod = (fromIntegral (0 :: Integer)) :: NominalDiffTime + , _restarts = [] + , _stats = emptyStats + , _logger = LogChan + , shutdownStrategy = strat + } + +emptyStats :: SupervisorStats +emptyStats = SupervisorStats { + _children = 0 + , _workers = 0 + , _supervisors = 0 + , _running = 0 + , _activeSupervisors = 0 + , _activeWorkers = 0 + , totalRestarts = 0 +-- , avgRestartFrequency = 0 + } + +serverDefinition :: PrioritisedProcessDefinition State +serverDefinition = prioritised processDefinition supPriorities + where + supPriorities :: [DispatchPriority State] + supPriorities = [ + prioritiseCast_ (\(IgnoreChildReq _) -> setPriority 100) + , prioritiseInfo_ (\(ProcessMonitorNotification _ _ _) -> setPriority 99 ) + , prioritiseInfo_ (\(DelayedRestart _ _) -> setPriority 80 ) + , prioritiseCall_ (\(_ :: FindReq) -> + (setPriority 10) :: Priority (Maybe (ChildRef, ChildSpec))) + ] + +processDefinition :: ProcessDefinition State +processDefinition = + defaultProcess { + apiHandlers = [ + Restricted.handleCast handleIgnore + -- adding, removing and (optionally) starting new child specs + , handleCall handleStopChild + , Restricted.handleCall handleDeleteChild + , Restricted.handleCallIf (input (\(AddChild immediate _) -> not immediate)) + handleAddChild + , handleCall handleStartNewChild + , handleCall handleStartChild + , handleCall handleRestartChild + -- stats/info + , Restricted.handleCall handleLookupChild + , Restricted.handleCall handleListChildren + , Restricted.handleCall handleGetStats + ] + , infoHandlers = [ handleInfo handleMonitorSignal + , handleInfo handleDelayedRestart + ] + , shutdownHandler = handleShutdown + , unhandledMessagePolicy = Drop + } :: ProcessDefinition State + +-------------------------------------------------------------------------------- +-- API Handlers -- +-------------------------------------------------------------------------------- + +handleLookupChild :: FindReq + -> RestrictedProcess State (Result (Maybe (ChildRef, ChildSpec))) +handleLookupChild (FindReq key) = getState >>= Restricted.reply . findChild key + +handleListChildren :: ListReq + -> RestrictedProcess State (Result [Child]) +handleListChildren _ = getState >>= Restricted.reply . toList . (^. specs) + +handleAddChild :: AddChildReq + -> RestrictedProcess State (Result AddChildResult) +handleAddChild req = getState >>= return . doAddChild req True >>= doReply + where doReply :: AddChildRes -> RestrictedProcess State (Result AddChildResult) + doReply (Added s) = putState s >> Restricted.reply (ChildAdded ChildStopped) + doReply (Exists e) = Restricted.reply (ChildFailedToStart $ StartFailureDuplicateChild e) + +handleIgnore :: IgnoreChildReq + -> RestrictedProcess State RestrictedAction +handleIgnore (IgnoreChildReq childPid) = do + {- not only must we take this child out of the `active' field, + we also delete the child spec if it's restart type is Temporary, + since restarting Temporary children is dis-allowed -} + state <- getState + let (cId, active') = + Map.updateLookupWithKey (\_ _ -> Nothing) childPid $ state ^. active + case cId of + Nothing -> Restricted.continue + Just c -> do + putState $ ( (active ^= active') + . (resetChildIgnored c) + $ state + ) + Restricted.continue + where + resetChildIgnored :: ChildKey -> State -> State + resetChildIgnored key state = + maybe state id $ updateChild key (setChildStopped True) state + +handleDeleteChild :: DeleteChild + -> RestrictedProcess State (Result DeleteChildResult) +handleDeleteChild (DeleteChild k) = getState >>= handleDelete k + where + handleDelete :: ChildKey + -> State + -> RestrictedProcess State (Result DeleteChildResult) + handleDelete key state = + let (prefix, suffix) = Seq.breakl ((== key) . childKey . snd) $ state ^. specs + in case (Seq.viewl suffix) of + EmptyL -> Restricted.reply ChildNotFound + child :< remaining -> tryDeleteChild child prefix remaining state + + tryDeleteChild (ref, spec) pfx sfx st + | ref == ChildStopped = do + putState $ ( (specs ^= pfx >< sfx) + $ bumpStats Specified (childType spec) decrement st + ) + Restricted.reply ChildDeleted + | otherwise = Restricted.reply $ ChildNotStopped ref + +handleStartChild :: State + -> StartChildReq + -> Process (ProcessReply StartChildResult State) +handleStartChild state (StartChild key) = + let child = findChild key state in + case child of + Nothing -> + reply ChildStartUnknownId state + Just (ref@(ChildRunning _), _) -> + reply (ChildStartFailed (StartFailureAlreadyRunning ref)) state + Just (ref@(ChildRunningExtra _ _), _) -> + reply (ChildStartFailed (StartFailureAlreadyRunning ref)) state + Just (ref@(ChildRestarting _), _) -> + reply (ChildStartFailed (StartFailureAlreadyRunning ref)) state + Just (_, spec) -> do + started <- doStartChild spec state + case started of + Left err -> reply (ChildStartFailed err) state + Right (ref, st') -> reply (ChildStartOk ref) st' + +handleStartNewChild :: State + -> AddChildReq + -> Process (ProcessReply AddChildResult State) +handleStartNewChild state req@(AddChild _ spec) = + let added = doAddChild req False state in + case added of + Exists e -> reply (ChildFailedToStart $ StartFailureDuplicateChild e) state + Added _ -> attemptStart state spec + where + attemptStart st ch = do + started <- tryStartChild ch + case started of + Left err -> reply (ChildFailedToStart err) $ removeChild spec st -- TODO: document this! + Right ref -> do + let st' = ( (specs ^: (|> (ref, spec))) + $ bumpStats Specified (childType spec) (+1) st + ) + in reply (ChildAdded ref) $ markActive st' ref ch + +handleRestartChild :: State + -> RestartChildReq + -> Process (ProcessReply RestartChildResult State) +handleRestartChild state (RestartChildReq key) = + let child = findChild key state in + case child of + Nothing -> + reply ChildRestartUnknownId state + Just (ref@(ChildRunning _), _) -> + reply (ChildRestartFailed (StartFailureAlreadyRunning ref)) state + Just (ref@(ChildRunningExtra _ _), _) -> + reply (ChildRestartFailed (StartFailureAlreadyRunning ref)) state + Just (ref@(ChildRestarting _), _) -> + reply (ChildRestartFailed (StartFailureAlreadyRunning ref)) state + Just (_, spec) -> do + started <- doStartChild spec state + case started of + Left err -> reply (ChildRestartFailed err) state + Right (ref, st') -> reply (ChildRestartOk ref) st' + +handleDelayedRestart :: State + -> DelayedRestart + -> Process (ProcessAction State) +handleDelayedRestart state (DelayedRestart key reason) = + let child = findChild key state in do + case child of + Nothing -> + continue state -- a child could've been stopped and removed by now + Just ((ChildRestarting childPid), spec) -> do + -- TODO: we ignore the unnecessary .active re-assignments in + -- tryRestartChild, in order to keep the code simple - it would be good to + -- clean this up so we don't have to though... + tryRestartChild childPid state (state ^. active) spec reason + Just other -> do + die $ ExitOther $ (supErrId ".handleDelayedRestart:InvalidState: ") ++ (show other) + +handleStopChild :: State + -> StopChildReq + -> Process (ProcessReply StopChildResult State) +handleStopChild state (StopChildReq key) = + let child = findChild key state in + case child of + Nothing -> + reply StopChildUnknownId state + Just (ChildStopped, _) -> + reply StopChildOk state + Just (ref, spec) -> + reply StopChildOk =<< doStopChild ref spec state + +handleGetStats :: StatsReq + -> RestrictedProcess State (Result SupervisorStats) +handleGetStats _ = Restricted.reply . (^. stats) =<< getState + +-------------------------------------------------------------------------------- +-- Child Monitoring -- +-------------------------------------------------------------------------------- + +handleMonitorSignal :: State + -> ProcessMonitorNotification + -> Process (ProcessAction State) +handleMonitorSignal state (ProcessMonitorNotification _ childPid reason) = do + let (cId, active') = + Map.updateLookupWithKey (\_ _ -> Nothing) childPid $ state ^. active + let mSpec = + case cId of + Nothing -> Nothing + Just c -> fmap snd $ findChild c state + case mSpec of + Nothing -> continue $ (active ^= active') state + Just spec -> tryRestart childPid state active' spec reason + +-------------------------------------------------------------------------------- +-- Child Monitoring -- +-------------------------------------------------------------------------------- + +handleShutdown :: ExitState State -> ExitReason -> Process () +handleShutdown state r@(ExitOther reason) = stopChildren (exitState state) r >> die reason +handleShutdown state r = stopChildren (exitState state) r + +-------------------------------------------------------------------------------- +-- Child Start/Restart Handling -- +-------------------------------------------------------------------------------- + +tryRestart :: ChildPid + -> State + -> Map ChildPid ChildKey + -> ChildSpec + -> DiedReason + -> Process (ProcessAction State) +tryRestart childPid state active' spec reason = do + sup <- getSelfPid + logEntry Log.debug $ do + mkReport "signalled restart" sup (childKey spec) (show reason) + case state ^. strategy of + RestartOne _ -> tryRestartChild childPid state active' spec reason + strat -> do + case (childRestart spec, isNormal reason) of + (Intrinsic, True) -> stopWith newState ExitNormal + (Transient, True) -> continue newState + (Temporary, _) -> continue removeTemp + _ -> tryRestartBranch strat spec reason $ newState + where + newState = (active ^= active') state + + removeTemp = removeChild spec $ newState + + isNormal (DiedException _) = False + isNormal _ = True + +tryRestartBranch :: RestartStrategy + -> ChildSpec + -> DiedReason + -> State + -> Process (ProcessAction State) +tryRestartBranch rs sp dr st = -- TODO: use DiedReason for logging... + let mode' = mode rs + tree' = case rs of + RestartAll _ _ -> childSpecs + RestartLeft _ _ -> subTreeL + RestartRight _ _ -> subTreeR + _ -> error "IllegalState" + proc = case mode' of + RestartEach _ -> stopStart (order mode') + _ -> restartBranch mode' + in do us <- getSelfPid + a <- proc tree' + report $ SupervisorBranchRestarted us (childKey sp) dr rs + return a + where + stopStart :: RestartOrder -> ChildSpecs -> Process (ProcessAction State) + stopStart order' tree = do + let tree' = case order' of + LeftToRight -> tree + RightToLeft -> Seq.reverse tree + state <- addRestart activeState + case state of + Nothing -> do us <- getSelfPid + let reason = errorMaxIntensityReached + report $ SupervisorShutdown us (shutdownStrategy st) reason + die reason + Just st' -> apply (foldlM stopStartIt st' tree') + + restartBranch :: RestartMode -> ChildSpecs -> Process (ProcessAction State) + restartBranch mode' tree = do + state <- addRestart activeState + case state of + Nothing -> die errorMaxIntensityReached + Just st' -> do + let (stopTree, startTree) = mkTrees mode' tree + foldlM stopIt st' stopTree >>= \s -> apply $ foldlM startIt s startTree + + mkTrees :: RestartMode -> ChildSpecs -> (ChildSpecs, ChildSpecs) + mkTrees (RestartInOrder LeftToRight) t = (t, t) + mkTrees (RestartInOrder RightToLeft) t = let rev = Seq.reverse t in (rev, rev) + mkTrees (RestartRevOrder LeftToRight) t = (t, Seq.reverse t) + mkTrees (RestartRevOrder RightToLeft) t = (Seq.reverse t, t) + mkTrees _ _ = error "mkTrees.INVALID_STATE" + + stopStartIt :: State -> Child -> Process State + stopStartIt s ch@(cr, cs) = do + us <- getSelfPid + cPid <- resolve cr + report $ SupervisedChildRestarting us cPid (childKey cs) (ExitOther "RestartedBySupervisor") + doStopChild cr cs s >>= (flip startIt) ch + + stopIt :: State -> Child -> Process State + stopIt s (cr, cs) = do + us <- getSelfPid + cPid <- resolve cr + report $ SupervisedChildRestarting us cPid (childKey cs) (ExitOther "RestartedBySupervisor") + doStopChild cr cs s + + startIt :: State -> Child -> Process State + startIt s (_, cs) + | isTemporary (childRestart cs) = return $ removeChild cs s + | otherwise = ensureActive cs =<< doStartChild cs s + + -- Note that ensureActive will kill this (supervisor) process if + -- doStartChild fails, simply because the /only/ failure that can + -- come out of that function (as `Left err') is *bad closure* and + -- that should have either been picked up during init (i.e., caused + -- the super to refuse to start) or been removed during `startChild' + -- or later on. Any other kind of failure will crop up (once we've + -- finished the restart sequence) as a monitor signal. + ensureActive :: ChildSpec + -> Either StartFailure (ChildRef, State) + -> Process State + ensureActive cs it + | (Right (ref, st')) <- it = return $ markActive st' ref cs + | (Left err) <- it = die $ ExitOther $ branchErrId ++ (childKey cs) ++ ": " ++ (show err) + | otherwise = error "IllegalState" + + branchErrId :: String + branchErrId = supErrId ".tryRestartBranch:child=" + + apply :: (Process State) -> Process (ProcessAction State) + apply proc = do + catchExit (proc >>= continue) (\(_ :: ProcessId) -> stop) + + activeState = maybe st id $ updateChild (childKey sp) + (setChildStopped False) st + + subTreeL :: ChildSpecs + subTreeL = + let (prefix, suffix) = splitTree Seq.breakl + in case (Seq.viewl suffix) of + child :< _ -> prefix |> child + EmptyL -> prefix + + subTreeR :: ChildSpecs + subTreeR = + let (prefix, suffix) = splitTree Seq.breakr + in case (Seq.viewr suffix) of + _ :> child -> child <| prefix + EmptyR -> prefix + + splitTree splitWith = splitWith ((== childKey sp) . childKey . snd) childSpecs + + childSpecs :: ChildSpecs + childSpecs = + let cs = activeState ^. specs + ck = childKey sp + rs' = childRestart sp + in case (isTransient rs', isTemporary rs', dr) of + (True, _, DiedNormal) -> filter ((/= ck) . childKey . snd) cs + (_, True, _) -> filter ((/= ck) . childKey . snd) cs + _ -> cs + +{- restartParallel :: ChildSpecs + -> RestartOrder + -> Process (ProcessAction State) + restartParallel tree order = do + liftIO $ putStrLn "handling parallel restart" + let tree' = case order of + LeftToRight -> tree + RightToLeft -> Seq.reverse tree + + -- TODO: THIS IS INCORRECT... currently (below), we stop + -- the branch in parallel, but wait on all the exits and then + -- restart sequentially (based on 'order'). That's not what the + -- 'RestartParallel' mode advertised, but more importantly, it's + -- not clear what the semantics for error handling (viz restart errors) + -- should actually be. + + asyncs <- forM (toList tree') $ \ch -> async $ asyncStop ch + (_errs, st') <- foldlM collectExits ([], activeState) asyncs + -- TODO: report errs + apply $ foldlM startIt st' tree' + where + asyncStop :: Child -> Process (Maybe (ChildKey, ChildPid)) + asyncStop (cr, cs) = do + mPid <- resolve cr + case mPid of + Nothing -> return Nothing + Just childPid -> do + void $ doStopChild cr cs activeState + return $ Just (childKey cs, childPid) + + collectExits :: ([ExitReason], State) + -> Async (Maybe (ChildKey, ChildPid)) + -> Process ([ExitReason], State) + collectExits (errs, state) hAsync = do + -- we perform a blocking wait on each handle, since we'll + -- always wait until the last shutdown has occurred anyway + asyncResult <- wait hAsync + let res = mergeState asyncResult state + case res of + Left err -> return ((err:errs), state) + Right st -> return (errs, st) + + mergeState :: AsyncResult (Maybe (ChildKey, ChildPid)) + -> State + -> Either ExitReason State + mergeState (AsyncDone Nothing) state = Right state + mergeState (AsyncDone (Just (key, childPid))) state = Right $ mergeIt key childPid state + mergeState (AsyncFailed r) _ = Left $ ExitOther (show r) + mergeState (AsyncLinkFailed r) _ = Left $ ExitOther (show r) + mergeState _ _ = Left $ ExitOther "IllegalState" + + mergeIt :: ChildKey -> ChildPid -> State -> State + mergeIt key childPid state = + -- TODO: lookup the old ref -> childPid and delete from the active map + ( (active ^: Map.delete childPid) + $ maybe state id (updateChild key (setChildStopped False) state) + ) + -} + +tryRestartChild :: ChildPid + -> State + -> Map ChildPid ChildKey + -> ChildSpec + -> DiedReason + -> Process (ProcessAction State) +tryRestartChild childPid st active' spec reason + | DiedNormal <- reason + , True <- isTransient (childRestart spec) = continue childDown + | True <- isTemporary (childRestart spec) = continue childRemoved + | DiedNormal <- reason + , True <- isIntrinsic (childRestart spec) = stopWith updateStopped ExitNormal + | otherwise = doRestartChild childPid spec reason st + where + childDown = (active ^= active') $ updateStopped + childRemoved = (active ^= active') $ removeChild spec st + updateStopped = maybe st id $ updateChild chKey (setChildStopped False) st + chKey = childKey spec + +doRestartChild :: ChildPid -> ChildSpec -> DiedReason -> State -> Process (ProcessAction State) +doRestartChild pid spec reason state = do -- TODO: use ChildPid and DiedReason to log + state' <- addRestart state + case state' of + Nothing -> -- die errorMaxIntensityReached + case (childRestartDelay spec) of + Nothing -> die errorMaxIntensityReached + Just del -> doRestartDelay pid del spec reason state + Just st -> do + sup <- getSelfPid + report $ SupervisedChildRestarting sup (Just pid) (childKey spec) (ExitOther $ show reason) + start' <- doStartChild spec st + case start' of + Right (ref, st') -> continue $ markActive st' ref spec + Left err -> do + -- All child failures are handled via monitor signals, apart from + -- BadClosure and UnresolvableAddress from the StarterProcess + -- variants of ChildStart, which both come back from + -- doStartChild as (Left err). + if isTemporary (childRestart spec) + then do + logEntry Log.warning $ + mkReport "Error in temporary child" sup (childKey spec) (show err) + continue $ ( (active ^: Map.filter (/= chKey)) + . (bumpStats Active chType decrement) + . (bumpStats Specified chType decrement) + $ removeChild spec st) + else do + logEntry Log.error $ + mkReport "Unrecoverable error in child. Stopping supervisor" + sup (childKey spec) (show err) + stopWith st $ ExitOther $ "Unrecoverable error in child " ++ (childKey spec) + where + chKey = childKey spec + chType = childType spec + + +doRestartDelay :: ChildPid + -> TimeInterval + -> ChildSpec + -> DiedReason + -> State + -> Process (ProcessAction State) +doRestartDelay oldPid rDelay spec reason state = do + evalAfter rDelay + (DelayedRestart (childKey spec) reason) + $ ( (active ^: Map.filter (/= chKey)) + . (bumpStats Active chType decrement) + -- . (restarts ^= []) + $ maybe state id (updateChild chKey (setChildRestarting oldPid) state) + ) + where + chKey = childKey spec + chType = childType spec + +addRestart :: State -> Process (Maybe State) +addRestart state = do + now <- liftIO $ getCurrentTime + let acc = foldl' (accRestarts now) [] (now:restarted) + case length acc of + n | n > maxAttempts -> return Nothing + _ -> return $ Just $ (restarts ^= acc) $ state + where + maxAttempts = maxNumberOfRestarts $ maxR $ maxIntensity + slot = state ^. restartPeriod + restarted = state ^. restarts + maxIntensity = state ^. strategy .> restartIntensity + + accRestarts :: UTCTime -> [UTCTime] -> UTCTime -> [UTCTime] + accRestarts now' acc r = + let diff = diffUTCTime now' r in + if diff > slot then acc else (r:acc) + +doStartChild :: ChildSpec + -> State + -> Process (Either StartFailure (ChildRef, State)) +doStartChild spec st = do + restart <- tryStartChild spec + case restart of + Left f -> return $ Left f + Right p -> do + let mState = updateChild chKey (chRunning p) st + case mState of + -- TODO: better error message if the child is unrecognised + Nothing -> die $ (supErrId ".doStartChild.InternalError:") ++ show spec + Just s' -> return $ Right $ (p, markActive s' p spec) + where + chKey = childKey spec + + chRunning :: ChildRef -> Child -> Prefix -> Suffix -> State -> Maybe State + chRunning newRef (_, chSpec) prefix suffix st' = + Just $ ( (specs ^= prefix >< ((newRef, chSpec) <| suffix)) + $ bumpStats Active (childType spec) (+1) st' + ) + +tryStartChild :: ChildSpec + -> Process (Either StartFailure ChildRef) +tryStartChild ChildSpec{..} = + case childStart of + RunClosure proc -> do + -- TODO: cache your closures!!! + mProc <- catch (unClosure proc >>= return . Right) + (\(e :: SomeException) -> return $ Left (show e)) + case mProc of + Left err -> logStartFailure $ StartFailureBadClosure err + Right p -> wrapClosure childKey childRegName p >>= return . Right + CreateHandle fn -> do + mFn <- catch (unClosure fn >>= return . Right) + (\(e :: SomeException) -> return $ Left (show e)) + case mFn of + Left err -> logStartFailure $ StartFailureBadClosure err + Right fn' -> do + wrapHandle childKey childRegName fn' >>= return . Right + where + logStartFailure sf = do + sup <- getSelfPid + -- logEntry Log.error $ mkReport "Child Start Error" sup childKey (show sf) + report $ SupervisedChildStartFailure sup sf childKey + return $ Left sf + + wrapClosure :: ChildKey + -> Maybe RegisteredName + -> Process () + -> Process ChildRef + wrapClosure key regName proc = do + supervisor <- getSelfPid + childPid <- spawnLocal $ do + self <- getSelfPid + link supervisor -- die if our parent dies + maybeRegister regName self + () <- expect -- wait for a start signal (pid is still private) + -- we translate `ExitShutdown' into a /normal/ exit + (proc + `catchesExit` [ + (\_ m -> handleMessageIf m (\r -> r == ExitShutdown) + (\_ -> return ())) + , (\_ m -> handleMessageIf m (\(ExitOther _) -> True) + (\r -> logExit supervisor self r)) + ]) + `catches` [ Handler $ filterInitFailures supervisor self + , Handler $ logFailure supervisor self ] + void $ monitor childPid + send childPid () + let cRef = ChildRunning childPid + report $ SupervisedChildStarted supervisor cRef key + return cRef + + wrapHandle :: ChildKey + -> Maybe RegisteredName + -> (SupervisorPid -> Process (ChildPid, Message)) + -> Process ChildRef + wrapHandle key regName proc = do + super <- getSelfPid + (childPid, msg) <- proc super + void $ monitor childPid + maybeRegister regName childPid + let cRef = ChildRunningExtra childPid msg + report $ SupervisedChildStarted super cRef key + return cRef + + maybeRegister :: Maybe RegisteredName -> ChildPid -> Process () + maybeRegister Nothing _ = return () + maybeRegister (Just (LocalName n)) pid = register n pid + maybeRegister (Just (CustomRegister clj)) pid = do + -- TODO: cache your closures!!! + mProc <- catch (unClosure clj >>= return . Right) + (\(e :: SomeException) -> return $ Left (show e)) + case mProc of + Left err -> die $ ExitOther (show err) + Right p -> p pid + +filterInitFailures :: SupervisorPid + -> ChildPid + -> ChildInitFailure + -> Process () +filterInitFailures sup childPid ex = do + case ex of + ChildInitFailure _ -> do + -- This is used as a `catches` handler in multiple places + -- and matches first before the other handlers that + -- would call logFailure. + -- We log here to avoid silent failure in those cases. + -- logEntry Log.error $ mkReport "ChildInitFailure" sup (show childPid) (show ex) + report $ SupervisedChildInitFailed sup childPid ex + liftIO $ throwIO ex + ChildInitIgnore -> Unsafe.cast sup $ IgnoreChildReq childPid + +-------------------------------------------------------------------------------- +-- Child Stop/Shutdown -- +-------------------------------------------------------------------------------- + +stopChildren :: State -> ExitReason -> Process () +stopChildren state er = do + us <- getSelfPid + let strat = shutdownStrategy state + report $ SupervisorShutdown us strat er + case strat of + ParallelShutdown -> do + let allChildren = toList $ state ^. specs + terminatorPids <- forM allChildren $ \ch -> do + pid <- spawnLocal $ void $ syncStop ch $ (active ^= Map.empty) state + mRef <- monitor pid + return (mRef, pid) + terminationErrors <- collectExits [] $ zip terminatorPids (map snd allChildren) + -- it seems these would also be logged individually in doStopChild + case terminationErrors of + [] -> return () + _ -> do + sup <- getSelfPid + void $ logEntry Log.error $ + mkReport "Errors in stopChildren / ParallelShutdown" + sup "n/a" (show terminationErrors) + SequentialShutdown ord -> do + let specs' = state ^. specs + let allChildren = case ord of + RightToLeft -> Seq.reverse specs' + LeftToRight -> specs' + void $ foldlM (flip syncStop) state (toList allChildren) + where + syncStop :: Child -> State -> Process State + syncStop (cr, cs) state' = doStopChild cr cs state' + + collectExits :: [(ProcessId, DiedReason)] + -> [((MonitorRef, ProcessId), ChildSpec)] + -> Process [(ProcessId, DiedReason)] + collectExits errors [] = return errors + collectExits errors pids = do + (ref, pid, reason) <- receiveWait [ + match (\(ProcessMonitorNotification ref' pid' reason') -> do + return (ref', pid', reason')) + ] + let remaining = [p | p <- pids, (snd $ fst p) /= pid] + let spec = List.lookup (ref, pid) pids + case (reason, spec) of + (DiedUnknownId, _) -> collectExits errors remaining + (DiedNormal, _) -> collectExits errors remaining + (_, Nothing) -> collectExits errors remaining + (DiedException _, Just sp') -> do + if (childStop sp') == StopImmediately + then collectExits errors remaining + else collectExits ((pid, reason):errors) remaining + _ -> collectExits ((pid, reason):errors) remaining + +doStopChild :: ChildRef -> ChildSpec -> State -> Process State +doStopChild ref spec state = do + us <- getSelfPid + mPid <- resolve ref + case mPid of + Nothing -> return state -- an already dead child is not an error + Just pid -> do + stopped <- childShutdown (childStop spec) pid state + report $ SupervisedChildStopped us ref stopped + -- state' <- shutdownComplete state pid stopped + return $ ( (active ^: Map.delete pid) + $ updateStopped + ) + where + {-shutdownComplete :: State -> ChildPid -> DiedReason -> Process State-} + {-shutdownComplete _ _ DiedNormal = return $ updateStopped-} + {-shutdownComplete state' pid (r :: DiedReason) = do-} + {-logShutdown (state' ^. logger) chKey pid r >> return state'-} + + chKey = childKey spec + updateStopped = maybe state id $ updateChild chKey (setChildStopped False) state + +childShutdown :: ChildStopPolicy + -> ChildPid + -> State + -> Process DiedReason +childShutdown policy childPid st = mask $ \restore -> do + case policy of + (StopTimeout t) -> exit childPid ExitShutdown >> await restore childPid t st + -- we ignore DiedReason for brutal kills + StopImmediately -> do + kill childPid "StoppedBySupervisor" + void $ await restore childPid Infinity st + return DiedNormal + where + await restore' childPid' delay state = do + -- We require and additional monitor here when child shutdown occurs + -- during a restart which was triggered by the /old/ monitor signal. + -- Just to be safe, we monitor the child immediately to be sure it goes. + mRef <- monitor childPid' + let recv = case delay of + Infinity -> receiveWait (matches mRef) >>= return . Just + NoDelay -> receiveTimeout 0 (matches mRef) + Delay t -> receiveTimeout (asTimeout t) (matches mRef) + -- let recv' = if monitored then recv else withMonitor childPid' recv + res <- recv `finally` (unmonitor mRef) + restore' $ maybe (childShutdown StopImmediately childPid' state) return res + + matches :: MonitorRef -> [Match DiedReason] + matches m = [ + matchIf (\(ProcessMonitorNotification m' _ _) -> m == m') + (\(ProcessMonitorNotification _ _ r) -> return r) + ] + +-------------------------------------------------------------------------------- +-- Loging/Reporting -- +-------------------------------------------------------------------------------- + +errorMaxIntensityReached :: ExitReason +errorMaxIntensityReached = ExitOther "ReachedMaxRestartIntensity" + +report :: MxSupervisor -> Process () +report = mxNotify . MxUser . unsafeWrapMessage + +{-logShutdown :: LogSink -> ChildKey -> ChildPid -> DiedReason -> Process ()-} +{-logShutdown log' child childPid reason = do-} + {-sup <- getSelfPid-} + {-Log.info log' $ mkReport banner sup (show childPid) shutdownReason-} + {-where-} + {-banner = "Child Shutdown Complete"-} + {-shutdownReason = (show reason) ++ ", child-key: " ++ child-} + +logExit :: SupervisorPid -> ChildPid -> ExitReason -> Process () +logExit sup pid er = do + report $ SupervisedChildDied sup pid er + +logFailure :: SupervisorPid -> ChildPid -> SomeException -> Process () +logFailure sup childPid ex = do + logEntry Log.notice $ mkReport "Detected Child Exit" sup (show childPid) (show ex) + liftIO $ throwIO ex + +logEntry :: (LogChan -> LogText -> Process ()) -> String -> Process () +logEntry lg = Log.report lg Log.logChannel + +mkReport :: String -> SupervisorPid -> String -> String -> String +mkReport b s c r = foldl' (\x xs -> xs ++ " " ++ x) "" (reverse items) + where + items :: [String] + items = [ "[" ++ s' ++ "]" | s' <- [ b + , "supervisor: " ++ show s + , "child: " ++ c + , "reason: " ++ r] ] + +-------------------------------------------------------------------------------- +-- Accessors and State/Stats Utilities -- +-------------------------------------------------------------------------------- + +type Ignored = Bool + +-- TODO: test that setChildStopped does not re-order the 'specs sequence + +setChildStopped :: Ignored -> Child -> Prefix -> Suffix -> State -> Maybe State +setChildStopped ignored child prefix remaining st = + let spec = snd child + rType = childRestart spec + newRef = if ignored then ChildStartIgnored else ChildStopped + in case isTemporary rType of + True -> Just $ (specs ^= prefix >< remaining) $ st + False -> Just $ (specs ^= prefix >< ((newRef, spec) <| remaining)) st + +setChildRestarting :: ChildPid -> Child -> Prefix -> Suffix -> State -> Maybe State +setChildRestarting oldPid child prefix remaining st = + let spec = snd child + newRef = ChildRestarting oldPid + in Just $ (specs ^= prefix >< ((newRef, spec) <| remaining)) st + +-- setChildStarted :: ChildPid -> + +doAddChild :: AddChildReq -> Bool -> State -> AddChildRes +doAddChild (AddChild _ spec) update st = + let chType = childType spec + in case (findChild (childKey spec) st) of + Just (ref, _) -> Exists ref + Nothing -> + case update of + True -> Added $ ( (specs ^: (|> (ChildStopped, spec))) + $ bumpStats Specified chType (+1) st + ) + False -> Added st + +updateChild :: ChildKey + -> (Child -> Prefix -> Suffix -> State -> Maybe State) + -> State + -> Maybe State +updateChild key updateFn state = + let (prefix, suffix) = Seq.breakl ((== key) . childKey . snd) $ state ^. specs + in case (Seq.viewl suffix) of + EmptyL -> Nothing + child :< remaining -> updateFn child prefix remaining state + +removeChild :: ChildSpec -> State -> State +removeChild spec state = + let k = childKey spec + in specs ^: filter ((/= k) . childKey . snd) $ state + +-- DO NOT call this function unless you've verified the ChildRef first. +markActive :: State -> ChildRef -> ChildSpec -> State +markActive state ref spec = + case ref of + ChildRunning (pid :: ChildPid) -> inserted pid + ChildRunningExtra pid _ -> inserted pid + _ -> error $ "InternalError" + where + inserted pid' = active ^: Map.insert pid' (childKey spec) $ state + +decrement :: Int -> Int +decrement n = n - 1 + +-- this is O(n) in the worst case, which is a bit naff, but we +-- can optimise it later with a different data structure, if required +findChild :: ChildKey -> State -> Maybe (ChildRef, ChildSpec) +findChild key st = find ((== key) . childKey . snd) $ st ^. specs + +bumpStats :: StatsType -> ChildType -> (Int -> Int) -> State -> State +bumpStats Specified Supervisor fn st = (bump fn) . (stats .> supervisors ^: fn) $ st +bumpStats Specified Worker fn st = (bump fn) . (stats .> workers ^: fn) $ st +bumpStats Active Worker fn st = (stats .> running ^: fn) . (stats .> activeWorkers ^: fn) $ st +bumpStats Active Supervisor fn st = (stats .> running ^: fn) . (stats .> activeSupervisors ^: fn) $ st + +bump :: (Int -> Int) -> State -> State +bump with' = stats .> children ^: with' + +isTemporary :: RestartPolicy -> Bool +isTemporary = (== Temporary) + +isTransient :: RestartPolicy -> Bool +isTransient = (== Transient) + +isIntrinsic :: RestartPolicy -> Bool +isIntrinsic = (== Intrinsic) + +active :: Accessor State (Map ChildPid ChildKey) +active = accessor _active (\act' st -> st { _active = act' }) + +strategy :: Accessor State RestartStrategy +strategy = accessor _strategy (\s st -> st { _strategy = s }) + +restartIntensity :: Accessor RestartStrategy RestartLimit +restartIntensity = accessor intensity (\i l -> l { intensity = i }) + +-- | The "RestartLimit" for a given "RestartStrategy" +getRestartIntensity :: RestartStrategy -> RestartLimit +getRestartIntensity = (^. restartIntensity) + +restartPeriod :: Accessor State NominalDiffTime +restartPeriod = accessor _restartPeriod (\p st -> st { _restartPeriod = p }) + +restarts :: Accessor State [UTCTime] +restarts = accessor _restarts (\r st -> st { _restarts = r }) + +specs :: Accessor State ChildSpecs +specs = accessor _specs (\sp' st -> st { _specs = sp' }) + +stats :: Accessor State SupervisorStats +stats = accessor _stats (\st' st -> st { _stats = st' }) + +logger :: Accessor State LogSink +logger = accessor _logger (\l st -> st { _logger = l }) + +children :: Accessor SupervisorStats Int +children = accessor _children (\c st -> st { _children = c }) + +-- | How many child specs are defined for this supervisor +definedChildren :: SupervisorStats -> Int +definedChildren = (^. children) + +workers :: Accessor SupervisorStats Int +workers = accessor _workers (\c st -> st { _workers = c }) + +-- | How many child specs define a worker (non-supervisor) +definedWorkers :: SupervisorStats -> Int +definedWorkers = (^. workers) + +supervisors :: Accessor SupervisorStats Int +supervisors = accessor _supervisors (\c st -> st { _supervisors = c }) + +-- | How many child specs define a supervisor? +definedSupervisors :: SupervisorStats -> Int +definedSupervisors = (^. supervisors) + +running :: Accessor SupervisorStats Int +running = accessor _running (\r st -> st { _running = r }) + +-- | How many running child processes. +runningChildren :: SupervisorStats -> Int +runningChildren = (^. running) + +activeWorkers :: Accessor SupervisorStats Int +activeWorkers = accessor _activeWorkers (\c st -> st { _activeWorkers = c }) + +-- | How many worker (non-supervisor) child processes are running. +runningWorkers :: SupervisorStats -> Int +runningWorkers = (^. activeWorkers) + +activeSupervisors :: Accessor SupervisorStats Int +activeSupervisors = accessor _activeSupervisors (\c st -> st { _activeSupervisors = c }) + +-- | How many supervisor child processes are running +runningSupervisors :: SupervisorStats -> Int +runningSupervisors = (^. activeSupervisors) diff --git a/packages/distributed-process-supervisor/src/Control/Distributed/Process/Supervisor/Management.hs b/packages/distributed-process-supervisor/src/Control/Distributed/Process/Supervisor/Management.hs new file mode 100644 index 00000000..160a3671 --- /dev/null +++ b/packages/distributed-process-supervisor/src/Control/Distributed/Process/Supervisor/Management.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Distributed.Process.Supervisor.Management +-- Copyright : (c) Tim Watson 2017 +-- License : BSD3 (see the file LICENSE) +-- +-- Maintainer : Tim Watson +-- Stability : experimental +-- Portability : non-portable (requires concurrency) +-- +----------------------------------------------------------------------------- + +module Control.Distributed.Process.Supervisor.Management + ( supervisionAgentId + , supervisionMonitor + , monitorSupervisor + , unmonitorSupervisor + -- * Mx Event Type + , MxSupervisor(..) + ) +where +import Control.DeepSeq (NFData) +import Control.Distributed.Process + ( ProcessId + , Process() + , ReceivePort() + , newChan + , sendChan + , getSelfPid + , unwrapMessage + ) +import Control.Distributed.Process.Internal.Types (SendPort(..)) +import Control.Distributed.Process.Management + ( MxAgentId(..) + , MxAgent() + , MxEvent(MxProcessDied, MxUser) + , mxAgent + , mxSink + , mxReady + , liftMX + , mxGetLocal + , mxSetLocal + , mxNotify + ) +import Control.Distributed.Process.Supervisor.Types + ( MxSupervisor(..) + , SupervisorPid + ) +import Data.Binary +import Data.Foldable (mapM_) +import Data.Hashable (Hashable(..)) +import Control.Distributed.Process.Extras.Internal.Containers.MultiMap (MultiMap) +import qualified Control.Distributed.Process.Extras.Internal.Containers.MultiMap as Map + +import Data.Typeable (Typeable) +import GHC.Generics + +data Register = Register !SupervisorPid !ProcessId !(SendPort MxSupervisor) + deriving (Typeable, Generic) +instance Binary Register where +instance NFData Register where + +data UnRegister = UnRegister !SupervisorPid !ProcessId + deriving (Typeable, Generic) +instance Binary UnRegister where +instance NFData UnRegister where + +newtype SupMxChan = SupMxChan { smxc :: SendPort MxSupervisor } + deriving (Typeable, Generic, Show) +instance Binary SupMxChan +instance NFData SupMxChan +instance Hashable SupMxChan where + hashWithSalt salt sp = hashWithSalt salt $ sendPortId (smxc sp) +instance Eq SupMxChan where + (==) a b = (sendPortId $ smxc a) == (sendPortId $ smxc b) + +type State = MultiMap SupervisorPid (ProcessId, SupMxChan) + +-- | The @MxAgentId@ for the node monitoring agent. +supervisionAgentId :: MxAgentId +supervisionAgentId = MxAgentId "service.monitoring.supervision" + +-- | Monitor the supervisor for the given pid. Binds a typed channel to the +-- calling process, to which the resulting @ReceivePort@ belongs. +-- +-- Multiple monitors can be created for any @calling process <-> sup@ pair. +-- Each monitor maintains its own typed channel, which will only contain +-- "MxSupervisor" entries obtained /after/ the channel was established. +-- +monitorSupervisor :: SupervisorPid -> Process (ReceivePort MxSupervisor) +monitorSupervisor sup = do + us <- getSelfPid + (sp, rp) <- newChan + mxNotify $ Register sup us sp + return rp + +-- | Removes all monitors for @sup@, associated with the calling process. +-- It is not possible to delete individual monitors (i.e. typed channels). +-- +unmonitorSupervisor :: SupervisorPid -> Process () +unmonitorSupervisor sup = getSelfPid >>= mxNotify . UnRegister sup + +-- | Starts the supervision monitoring agent. +supervisionMonitor :: Process ProcessId +supervisionMonitor = do + mxAgent supervisionAgentId initState [ + (mxSink $ \(Register sup pid sp) -> do + mxSetLocal . Map.insert sup (pid, SupMxChan sp) =<< mxGetLocal + mxReady) + , (mxSink $ \(UnRegister sup pid) -> do + st <- mxGetLocal + mxSetLocal $ Map.filterWithKey (\k v -> if k == sup then (fst v) /= pid else True) st + mxReady) + , (mxSink $ \(ev :: MxEvent) -> do + case ev of + MxUser msg -> goNotify msg >> mxReady + MxProcessDied pid _ -> do st <- mxGetLocal + mxSetLocal $ Map.filter ((/= pid) . fst) st + mxReady + _ -> mxReady) + ] + where + initState :: State + initState = Map.empty + + goNotify msg = do + ev <- liftMX $ unwrapMessage msg :: MxAgent State (Maybe MxSupervisor) + case ev of + Just ev' -> do st <- mxGetLocal + mapM_ (liftMX . (flip sendChan) ev' . smxc . snd) + (maybe [] id $ Map.lookup (supervisorPid ev') st) + Nothing -> return () diff --git a/packages/distributed-process-supervisor/src/Control/Distributed/Process/Supervisor/Types.hs b/packages/distributed-process-supervisor/src/Control/Distributed/Process/Supervisor/Types.hs new file mode 100644 index 00000000..e330fc14 --- /dev/null +++ b/packages/distributed-process-supervisor/src/Control/Distributed/Process/Supervisor/Types.hs @@ -0,0 +1,447 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} +----------------------------------------------------------------------------- +-- | +-- Module : Control.Distributed.Process.Supervisor.Types +-- Copyright : (c) Tim Watson 2012 +-- License : BSD3 (see the file LICENSE) +-- +-- Maintainer : Tim Watson +-- Stability : experimental +-- Portability : non-portable (requires concurrency) +-- +----------------------------------------------------------------------------- +module Control.Distributed.Process.Supervisor.Types + ( -- * Defining and Running a Supervisor + ChildSpec(..) + , ChildKey + , ChildType(..) + , ChildStopPolicy(..) + , ChildStart(..) + , RegisteredName(LocalName, CustomRegister) + , RestartPolicy(..) + , ChildRef(..) + , isRunning + , isRestarting + , Child + , StaticLabel + , SupervisorPid + , ChildPid + -- * Limits and Defaults + , MaxRestarts(..) + , maxRestarts + , RestartLimit(..) + , limit + , defaultLimits + , RestartMode(..) + , RestartOrder(..) + , RestartStrategy(..) + , ShutdownMode(..) + , restartOne + , restartAll + , restartLeft + , restartRight + -- * Adding and Removing Children + , AddChildResult(..) + , StartChildResult(..) + , StopChildResult(..) + , DeleteChildResult(..) + , RestartChildResult(..) + -- * Additional (Misc) Types + , SupervisorStats(..) + , StartFailure(..) + , ChildInitFailure(..) + , MxSupervisor(..) + ) where + +import GHC.Generics +import Data.Typeable (Typeable) +import Data.Binary + +import Control.DeepSeq (NFData) +import Control.Distributed.Process hiding (call) +import Control.Distributed.Process.Serializable() +import Control.Distributed.Process.Extras.Internal.Types + ( ExitReason(..) + ) +import Control.Distributed.Process.Extras.Time +import Control.Distributed.Process.Extras.Internal.Primitives hiding (monitor) +import Control.Exception (Exception) +import Data.Hashable (Hashable) + +-- aliases for api documentation purposes + +-- | The "ProcessId" of a supervisor. +type SupervisorPid = ProcessId + +-- | The "ProcessId" of a supervised /child/. +type ChildPid = ProcessId + +-- | The maximum number of restarts a supervisor will tollerate, created by +-- evaluating "maxRestarts". +newtype MaxRestarts = MaxR { maxNumberOfRestarts :: Int } + deriving (Typeable, Generic, Show, Eq) +instance Binary MaxRestarts where +instance Hashable MaxRestarts where +instance NFData MaxRestarts where + +-- | Smart constructor for @MaxRestarts@. The maximum restart count must be a +-- positive integer, otherwise you will see @error "MaxR must be >= 0"@. +maxRestarts :: Int -> MaxRestarts +maxRestarts r | r >= 0 = MaxR r + | otherwise = error "MaxR must be >= 0" + +-- | A compulsary limit on the number of restarts that a supervisor will +-- tolerate before it stops all child processes and then itself. +-- If > @MaxRestarts@ occur within the specified @TimeInterval@, the child +-- will be stopped. This prevents the supervisor from entering an infinite loop +-- of child process stops and restarts. +-- +data RestartLimit = + RestartLimit + { maxR :: !MaxRestarts + , maxT :: !TimeInterval + } + deriving (Typeable, Generic, Show) +instance Binary RestartLimit where +instance NFData RestartLimit where + +-- | Smart constructor for "RestartLimit". +limit :: MaxRestarts -> TimeInterval -> RestartLimit +limit mr = RestartLimit mr + +-- | Default "RestartLimit" of @MaxR 1@ within @Seconds 1@. +defaultLimits :: RestartLimit +defaultLimits = limit (MaxR 1) (seconds 1) + +-- | Specifies the order in which a supervisor should apply restarts. +data RestartOrder = LeftToRight | RightToLeft + deriving (Typeable, Generic, Eq, Show) +instance Binary RestartOrder where +instance Hashable RestartOrder where +instance NFData RestartOrder where + +-- | Instructs a supervisor on how to restart its children. +data RestartMode = + RestartEach { order :: !RestartOrder } + {- ^ stop then start each child sequentially, i.e., @foldlM stopThenStart children@ -} + | RestartInOrder { order :: !RestartOrder } + {- ^ stop all children first, then restart them sequentially -} + | RestartRevOrder { order :: !RestartOrder } + {- ^ stop all children in the given order, but start them in reverse -} + deriving (Typeable, Generic, Show, Eq) +instance Binary RestartMode where +instance Hashable RestartMode where +instance NFData RestartMode where + +-- | Instructs a supervisor on how to instruct its children to stop running +-- when the supervisor itself is shutting down. +data ShutdownMode = SequentialShutdown !RestartOrder + | ParallelShutdown + deriving (Typeable, Generic, Show, Eq) +instance Binary ShutdownMode where +instance Hashable ShutdownMode where +instance NFData ShutdownMode where + +-- | Strategy used by a supervisor to handle child restarts, whether due to +-- unexpected child failure or explicit restart requests from a client. +-- +-- Some terminology: We refer to child processes managed by the same supervisor +-- as /siblings/. When restarting a child process, the 'RestartNone' policy +-- indicates that sibling processes should be left alone, whilst the 'RestartAll' +-- policy will cause /all/ children to be restarted (in the same order they were +-- started). +-- +-- The other two restart strategies refer to /prior/ and /subsequent/ +-- siblings, which describe's those children's configured position in insertion +-- order in the child specs. These latter modes allow one to control the order +-- in which siblings are restarted, and to exclude some siblings from restarting, +-- without having to resort to grouping them using a child supervisor. +-- +data RestartStrategy = + RestartOne + { intensity :: !RestartLimit + } -- ^ restart only the failed child process + | RestartAll + { intensity :: !RestartLimit + , mode :: !RestartMode + } -- ^ also restart all siblings + | RestartLeft + { intensity :: !RestartLimit + , mode :: !RestartMode + } -- ^ restart prior siblings (i.e., prior /start order/) + | RestartRight + { intensity :: !RestartLimit + , mode :: !RestartMode + } -- ^ restart subsequent siblings (i.e., subsequent /start order/) + deriving (Typeable, Generic, Show) +instance Binary RestartStrategy where +instance NFData RestartStrategy where + +-- | Provides a default 'RestartStrategy' for @RestartOne@. +-- > restartOne = RestartOne defaultLimits +-- +restartOne :: RestartStrategy +restartOne = RestartOne defaultLimits + +-- | Provides a default 'RestartStrategy' for @RestartAll@. +-- > restartOne = RestartAll defaultLimits (RestartEach LeftToRight) +-- +restartAll :: RestartStrategy +restartAll = RestartAll defaultLimits (RestartEach LeftToRight) + +-- | Provides a default 'RestartStrategy' for @RestartLeft@. +-- > restartOne = RestartLeft defaultLimits (RestartEach LeftToRight) +-- +restartLeft :: RestartStrategy +restartLeft = RestartLeft defaultLimits (RestartEach LeftToRight) + +-- | Provides a default 'RestartStrategy' for @RestartRight@. +-- > restartOne = RestartRight defaultLimits (RestartEach LeftToRight) +-- +restartRight :: RestartStrategy +restartRight = RestartRight defaultLimits (RestartEach LeftToRight) + +-- | Identifies a child process by name. +type ChildKey = String + +-- | A reference to a (possibly running) child. +data ChildRef = + ChildRunning !ChildPid -- ^ a reference to the (currently running) child + | ChildRunningExtra !ChildPid !Message -- ^ also a currently running child, with /extra/ child info + | ChildRestarting !ChildPid -- ^ a reference to the /old/ (previous) child (now restarting) + | ChildStopped -- ^ indicates the child is not currently running + | ChildStartIgnored -- ^ a non-temporary child exited with 'ChildInitIgnore' + deriving (Typeable, Generic, Show) +instance Binary ChildRef where +instance NFData ChildRef where + +instance Eq ChildRef where + ChildRunning p1 == ChildRunning p2 = p1 == p2 + ChildRunningExtra p1 _ == ChildRunningExtra p2 _ = p1 == p2 + ChildRestarting p1 == ChildRestarting p2 = p1 == p2 + ChildStopped == ChildStopped = True + ChildStartIgnored == ChildStartIgnored = True + _ == _ = False + +-- | @True@ if "ChildRef" is running. +isRunning :: ChildRef -> Bool +isRunning (ChildRunning _) = True +isRunning (ChildRunningExtra _ _) = True +isRunning _ = False + +-- | @True@ if "ChildRef" is restarting +isRestarting :: ChildRef -> Bool +isRestarting (ChildRestarting _) = True +isRestarting _ = False + +instance Resolvable ChildRef where + resolve (ChildRunning pid) = return $ Just pid + resolve (ChildRunningExtra pid _) = return $ Just pid + resolve _ = return Nothing + +-- these look a bit odd, but we basically want to avoid resolving +-- or sending to (ChildRestarting oldPid) +instance Routable ChildRef where + sendTo (ChildRunning addr) = sendTo addr + sendTo _ = error "invalid address for child process" + + unsafeSendTo (ChildRunning ch) = unsafeSendTo ch + unsafeSendTo _ = error "invalid address for child process" + +-- | Specifies whether the child is another supervisor, or a worker. +data ChildType = Worker | Supervisor + deriving (Typeable, Generic, Show, Eq) +instance Binary ChildType where +instance NFData ChildType where + +-- | Describes when a stopped child process should be restarted. +data RestartPolicy = + Permanent -- ^ a permanent child will always be restarted + | Temporary -- ^ a temporary child will /never/ be restarted + | Transient -- ^ A transient child will be restarted only if it stops abnormally + | Intrinsic -- ^ as 'Transient', but if the child exits normally, the supervisor also exits normally + deriving (Typeable, Generic, Eq, Show) +instance Binary RestartPolicy where +instance NFData RestartPolicy where + +-- | Governs how the supervisor will instruct child processes to stop. +data ChildStopPolicy = + StopTimeout !Delay + | StopImmediately + deriving (Typeable, Generic, Eq, Show) +instance Binary ChildStopPolicy where +instance NFData ChildStopPolicy where + +-- | Represents a registered name, for registration /locally/ using the +-- @register@ primitive, or via a @Closure (ChildPid -> Process ())@ such that +-- registration can be performed using alternative process registries. +data RegisteredName = + LocalName !String + | CustomRegister !(Closure (ChildPid -> Process ())) + deriving (Typeable, Generic) +instance Binary RegisteredName where +instance NFData RegisteredName where + +instance Show RegisteredName where + show (CustomRegister _) = "Custom Register" + show (LocalName n) = n + +-- | Defines the way in which a child process is to be started. +data ChildStart = + RunClosure !(Closure (Process ())) + | CreateHandle !(Closure (SupervisorPid -> Process (ChildPid, Message))) + deriving (Typeable, Generic, Show) +instance Binary ChildStart where +instance NFData ChildStart where + +-- | Specification for a child process. The child must be uniquely identified +-- by it's @childKey@ within the supervisor. The supervisor will start the child +-- itself, therefore @childRun@ should contain the child process' implementation +-- e.g., if the child is a long running server, this would be the server /loop/, +-- as with e.g., @ManagedProces.start@. +data ChildSpec = ChildSpec { + childKey :: !ChildKey + , childType :: !ChildType + , childRestart :: !RestartPolicy + , childRestartDelay :: !(Maybe TimeInterval) + , childStop :: !ChildStopPolicy + , childStart :: !ChildStart + , childRegName :: !(Maybe RegisteredName) + } deriving (Typeable, Generic, Show) +instance Binary ChildSpec where +instance NFData ChildSpec where + +-- | A child process failure during init will be reported using this datum +data ChildInitFailure = + ChildInitFailure !String -- ^ The init failed with the corresponding message + | ChildInitIgnore -- ^ The child told the supervisor to ignore its startup procedure + deriving (Typeable, Generic, Show) +instance Binary ChildInitFailure where +instance NFData ChildInitFailure where +instance Exception ChildInitFailure where + +-- | Statistics about a running supervisor +data SupervisorStats = SupervisorStats { + _children :: Int + , _supervisors :: Int + , _workers :: Int + , _running :: Int + , _activeSupervisors :: Int + , _activeWorkers :: Int + -- TODO: usage/restart/freq stats + , totalRestarts :: Int + } deriving (Typeable, Generic, Show) +instance Binary SupervisorStats where +instance NFData SupervisorStats where + +-- | Supervisor event data published to the management API +data MxSupervisor = + SupervisorBranchRestarted + { + supervisorPid :: SupervisorPid + , childSpecKey :: ChildKey + , diedReason :: DiedReason + , branchStrategy :: RestartStrategy + } -- ^ A branch restart took place + | SupervisedChildRestarting + { supervisorPid :: SupervisorPid + , childInScope :: Maybe ChildPid + , childSpecKey :: ChildKey + , exitReason :: ExitReason + } -- ^ A child is being restarted + | SupervisedChildStarted + { supervisorPid :: SupervisorPid + , childRef :: ChildRef + , childSpecKey :: ChildKey + } -- ^ A child has been started + | SupervisedChildStartFailure + { supervisorPid :: SupervisorPid + , startFailure :: StartFailure + , childSpecKey :: ChildKey + } -- ^ A child failed to start + | SupervisedChildDied + { supervisorPid :: SupervisorPid + , childPid :: ChildPid + , exitReason :: ExitReason + } -- ^ A child process death was detected + | SupervisedChildInitFailed + { supervisorPid :: SupervisorPid + , childPid :: ChildPid + , initFailure :: ChildInitFailure + } -- ^ A child failed during init + | SupervisedChildStopped + { supervisorPid :: SupervisorPid + , childRef :: ChildRef + , diedReason :: DiedReason + } -- ^ A child has been stopped + | SupervisorShutdown + { supervisorPid :: SupervisorPid + , shutdownMode :: ShutdownMode + , exitRason :: ExitReason + } -- ^ A supervisor is shutting down + deriving (Typeable, Generic, Show) +instance Binary MxSupervisor where +instance NFData MxSupervisor where + +-- | Static labels (in the remote table) are strings. +type StaticLabel = String + +-- | Provides failure information when (re-)start failure is indicated. +data StartFailure = + StartFailureDuplicateChild !ChildRef -- ^ a child with this 'ChildKey' already exists + | StartFailureAlreadyRunning !ChildRef -- ^ the child is already up and running + | StartFailureBadClosure !StaticLabel -- ^ a closure cannot be resolved + | StartFailureDied !DiedReason -- ^ a child died (almost) immediately on starting + deriving (Typeable, Generic, Show, Eq) +instance Binary StartFailure where +instance NFData StartFailure where + +-- | The result of a call to 'removeChild'. +data DeleteChildResult = + ChildDeleted -- ^ the child specification was successfully removed + | ChildNotFound -- ^ the child specification was not found + | ChildNotStopped !ChildRef -- ^ the child was not removed, as it was not stopped. + deriving (Typeable, Generic, Show, Eq) +instance Binary DeleteChildResult where +instance NFData DeleteChildResult where + +-- | A child represented as a @(ChildRef, ChildSpec)@ pair. +type Child = (ChildRef, ChildSpec) + +-- exported result types of internal APIs + +-- | The result of an @addChild@ request. +data AddChildResult = + ChildAdded !ChildRef -- ^ The child was added correctly + | ChildFailedToStart !StartFailure -- ^ The child failed to start + deriving (Typeable, Generic, Show, Eq) +instance Binary AddChildResult where +instance NFData AddChildResult where + +-- | The result of a @startChild@ request. +data StartChildResult = + ChildStartOk !ChildRef -- ^ The child started successfully + | ChildStartFailed !StartFailure -- ^ The child failed to start + | ChildStartUnknownId -- ^ The child key was not recognised by the supervisor + deriving (Typeable, Generic, Show, Eq) +instance Binary StartChildResult where +instance NFData StartChildResult where + +-- | The result of a @restartChild@ request. +data RestartChildResult = + ChildRestartOk !ChildRef -- ^ The child restarted successfully + | ChildRestartFailed !StartFailure -- ^ The child failed to restart + | ChildRestartUnknownId -- ^ The child key was not recognised by the supervisor + deriving (Typeable, Generic, Show, Eq) + +instance Binary RestartChildResult where +instance NFData RestartChildResult where + +-- | The result of a @stopChild@ request. +data StopChildResult = + StopChildOk -- ^ The child was stopped successfully + | StopChildUnknownId -- ^ The child key was not recognised by the supervisor + deriving (Typeable, Generic, Show, Eq) +instance Binary StopChildResult where +instance NFData StopChildResult where diff --git a/packages/distributed-process-supervisor/test-report.hs b/packages/distributed-process-supervisor/test-report.hs new file mode 100755 index 00000000..523ecf79 --- /dev/null +++ b/packages/distributed-process-supervisor/test-report.hs @@ -0,0 +1,10 @@ +#! /bin/sh + +HPC_DIR=dist/hpc + +cabal-dev clean +cabal-dev configure --enable-tests --enable-library-coverage +cabal-dev build +cabal-dev test + +open ${HPC_DIR}/html/*/hpc-index.html diff --git a/packages/distributed-process-supervisor/tests/TestSupervisor.hs b/packages/distributed-process-supervisor/tests/TestSupervisor.hs new file mode 100644 index 00000000..227e0b3f --- /dev/null +++ b/packages/distributed-process-supervisor/tests/TestSupervisor.hs @@ -0,0 +1,1468 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE Rank2Types #-} + +-- NOTICE: Some of these tests are /unsafe/, and will fail intermittently, since +-- they rely on ordering constraints which the Cloud Haskell runtime does not +-- guarantee. + +module Main where + +import Control.Concurrent.MVar + ( MVar + , newMVar + , putMVar + , takeMVar + ) +import qualified Control.Exception as Ex +import Control.Exception (throwIO) +import Control.Distributed.Process hiding (call, monitor, finally) +import Control.Distributed.Process.Closure +import Control.Distributed.Process.Node +import Control.Distributed.Process.Extras.Internal.Types +import Control.Distributed.Process.Extras.Internal.Primitives +import Control.Distributed.Process.Extras.SystemLog + ( LogLevel(Debug) + , systemLogFile + , addFormatter + , debug + , logChannel + ) +import Control.Distributed.Process.Extras.Time +import Control.Distributed.Process.Extras.Timer +import Control.Distributed.Process.Supervisor hiding (start, shutdown) +import qualified Control.Distributed.Process.Supervisor as Supervisor +import Control.Distributed.Process.Supervisor.Management + ( MxSupervisor(..) + , monitorSupervisor + , unmonitorSupervisor + , supervisionMonitor + ) +import Control.Distributed.Process.ManagedProcess.Client (shutdown) +import Control.Distributed.Process.Serializable() + +import Control.Distributed.Static (staticLabel) +import Control.Monad (void, unless, forM_, forM) +import Control.Monad.Catch (finally) +import Control.Rematch + ( equalTo + , is + , isNot + , isNothing + , isJust + ) + +import Data.ByteString.Lazy (empty) +import Data.Maybe (catMaybes) + +import Test.HUnit (Assertion, assertFailure) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import TestUtils hiding (waitForExit) +import qualified Network.Transport as NT + +import System.Random (mkStdGen, randomR) +-- test utilities + +expectedExitReason :: ProcessId -> String +expectedExitReason sup = "killed-by=" ++ (show sup) ++ + ",reason=StoppedBySupervisor" + +defaultWorker :: ChildStart -> ChildSpec +defaultWorker clj = + ChildSpec + { + childKey = "" + , childType = Worker + , childRestart = Temporary + , childRestartDelay = Nothing + , childStop = StopImmediately + , childStart = clj + , childRegName = Nothing + } + +tempWorker :: ChildStart -> ChildSpec +tempWorker clj = + (defaultWorker clj) + { + childKey = "temp-worker" + , childRestart = Temporary + } + +transientWorker :: ChildStart -> ChildSpec +transientWorker clj = + (defaultWorker clj) + { + childKey = "transient-worker" + , childRestart = Transient + } + +intrinsicWorker :: ChildStart -> ChildSpec +intrinsicWorker clj = + (defaultWorker clj) + { + childKey = "intrinsic-worker" + , childRestart = Intrinsic + } + +permChild :: ChildStart -> ChildSpec +permChild clj = + (defaultWorker clj) + { + childKey = "perm-child" + , childRestart = Permanent + } + +ensureProcessIsAlive :: ProcessId -> Process () +ensureProcessIsAlive pid = do + result <- isProcessAlive pid + expectThat result $ is True + +runInTestContext :: LocalNode + -> MVar () + -> ShutdownMode + -> RestartStrategy + -> [ChildSpec] + -> (ProcessId -> Process ()) + -> Assertion +runInTestContext node lock sm rs cs proc = do + Ex.bracket (takeMVar lock) (putMVar lock) $ \() -> runProcess node $ do + sup <- Supervisor.start rs sm cs + (proc sup) `finally` (exit sup ExitShutdown) + +data Context = Context { sup :: SupervisorPid + , sniffer :: Sniffer + , waitTimeout :: TimeInterval + , listSize :: Int + , split :: forall a . ([a] -> ([a], [a])) + } +type Sniffer = ReceivePort MxSupervisor + +mkRandom :: Int -> Int -> (Int, Int) +mkRandom minListSz maxListSz + | minListSz > maxListSz = error "nope" + | minListSz < 20 = mkRandom 20 maxListSz + | otherwise = + let gen = mkStdGen 273846 + (lSz :: Int, gen') = randomR (minListSz, maxListSz) gen + (sPt :: Int, _) = randomR (max 3 (round((fromIntegral lSz) / 3.15 :: Double) :: Int), lSz - 3) gen' + in (lSz, sPt) + +randomIshSizes :: (Int, Int) +randomIshSizes = mkRandom 20 1200 + +runInTestContext' :: LocalNode + -> ShutdownMode + -> RestartStrategy + -> [ChildSpec] + -> (Context -> Process ()) + -> Assertion +runInTestContext' node sm rs cs proc = do + liftIO $ do + -- we don't care about real randomness, just about selecting a vaguely + -- different sizes for each run... + let (lSz, sPt) = randomIshSizes + runProcess node $ do + sup <- Supervisor.start rs sm cs + sf <- monitorSupervisor sup + finally (proc $ Context sup sf (seconds 30) lSz (splitAt sPt)) + (exit sup ExitShutdown >> unmonitorSupervisor sup) + +verifyChildWasRestarted :: ChildKey -> ProcessId -> ProcessId -> Process () +verifyChildWasRestarted key pid sup = do + void $ waitForExit pid + cSpec <- lookupChild sup key + -- TODO: handle (ChildRestarting _) too! + case cSpec of + Just (ref, _) -> do Just pid' <- resolve ref + expectThat pid' $ isNot $ equalTo pid + _ -> do + liftIO $ assertFailure $ "unexpected child ref: " ++ (show (key, cSpec)) + +verifyChildWasNotRestarted :: ChildKey -> ProcessId -> ProcessId -> Process () +verifyChildWasNotRestarted key pid sup = do + void $ waitForExit pid + cSpec <- lookupChild sup key + case cSpec of + Just (ChildStopped, _) -> return () + _ -> liftIO $ assertFailure $ "unexpected child ref: " ++ (show (key, cSpec)) + +verifyTempChildWasRemoved :: ProcessId -> ProcessId -> Process () +verifyTempChildWasRemoved pid sup = do + void $ waitForExit pid + sleepFor 500 Millis + cSpec <- lookupChild sup "temp-worker" + expectThat cSpec isNothing + +waitForExit :: ProcessId -> Process DiedReason +waitForExit pid = do + monitor pid >>= waitForDown + +waitForDown :: Maybe MonitorRef -> Process DiedReason +waitForDown Nothing = error "invalid mref" +waitForDown (Just ref) = + receiveWait [ matchIf (\(ProcessMonitorNotification ref' _ _) -> ref == ref') + (\(ProcessMonitorNotification _ _ dr) -> return dr) ] + +waitForBranchRestartComplete :: Sniffer + -> ChildKey + -> Process () +waitForBranchRestartComplete sniff key = do + debug logChannel $ "waiting for branch restart..." + aux 10000 sniff Nothing -- `finally` unmonitorSupervisor sup + where + aux :: Int -> Sniffer -> Maybe MxSupervisor -> Process () + aux n s m + | n < 1 = liftIO $ assertFailure $ "Never Saw Branch Restarted for " ++ (show key) + | Just mx <- m + , SupervisorBranchRestarted{..} <- mx + , childSpecKey == key = return () + | Nothing <- m = receiveTimeout 100 [ matchChan s return ] >>= aux (n-1) s + | otherwise = aux (n-1) s Nothing + +verifySingleRestart :: Context + -> ChildKey + -> Process () +verifySingleRestart Context{..} key = do + sleep $ seconds 1 + let t = asTimeout waitTimeout + mx <- receiveChanTimeout t sniffer + case mx of + Just rs@SupervisedChildRestarting{} -> do + (childSpecKey rs) `shouldBe` equalTo key + mx' <- receiveChanTimeout t sniffer + case mx' of + Just cs@SupervisedChildStarted{} -> do + (childSpecKey cs) `shouldBe` equalTo key + debug logChannel $ "restart ok for " ++ (show cs) + _ -> liftIO $ assertFailure $ " Unexpected Waiting Child Started " ++ (show mx') + _ -> liftIO $ assertFailure $ "Unexpected Waiting Child Restarted " ++ (show mx) + +verifySeqStartOrder :: Context + -> [(ChildRef, Child)] + -> ChildKey + -> Process () +verifySeqStartOrder Context{..} xs toStop = do + -- xs == [(oldRef, (ref, spec))] in specified/insertion order + -- if shutdown is LeftToRight then that's correct, otherwise we + -- should expect the shutdowns in reverse order + sleep $ seconds 1 + let t = asTimeout waitTimeout + forM_ xs $ \(oCr, c@(cr, cs)) -> do + debug logChannel $ "checking restart " ++ (show c) + mx <- receiveTimeout t [ matchChan sniffer return ] + case mx of + Just SupervisedChildRestarting{..} -> do + debug logChannel $ "for restart " ++ (show childSpecKey) ++ " we're expecting " ++ (childKey cs) + childSpecKey `shouldBe` equalTo (childKey cs) + unless (childSpecKey == toStop) $ do + Just SupervisedChildStopped{..} <- receiveChanTimeout t sniffer + debug logChannel $ "for " ++ (show childRef) ++ " we're expecting " ++ (show oCr) + childRef `shouldBe` equalTo oCr + mx' <- receiveChanTimeout t sniffer + case mx' of + Just SupervisedChildStarted{..} -> childRef `shouldBe` equalTo cr + _ -> do + liftIO $ assertFailure $ "After Stopping " ++ (show cs) ++ + " received unexpected " ++ (show mx) + _ -> liftIO $ assertFailure $ "Bad Restart: " ++ (show mx) + +verifyStopStartOrder :: Context + -> [(ChildRef, Child)] + -> [Child] + -> ChildKey + -> Process () +verifyStopStartOrder Context{..} xs restarted toStop = do + -- xs == [(oldRef, (ref, spec))] in specified/insertion order + -- if shutdown is LeftToRight then that's correct, otherwise we + -- should expect the shutdowns in reverse order + sleep $ seconds 1 + let t = asTimeout waitTimeout + forM_ xs $ \(oCr, c@(_, cs)) -> do + debug logChannel $ "checking restart " ++ (show c) + mx <- receiveTimeout t [ matchChan sniffer return ] + case mx of + Just SupervisedChildRestarting{..} -> do + debug logChannel $ "for restart " ++ (show childSpecKey) ++ " we're expecting " ++ (childKey cs) + childSpecKey `shouldBe` equalTo (childKey cs) + if childSpecKey /= toStop + then do Just SupervisedChildStopped{..} <- receiveChanTimeout t sniffer + debug logChannel $ "for " ++ (show childRef) ++ " we're expecting " ++ (show oCr) + -- childRef `shouldBe` equalTo oCr + if childRef /= oCr + then debug logChannel $ "childRef " ++ (show childRef) ++ " /= " ++ (show oCr) + else return () + else return () + _ -> liftIO $ assertFailure $ "Bad Restart: " ++ (show mx) + + debug logChannel "checking start order..." + sleep $ seconds 1 + forM_ restarted $ \(cr, _) -> do + debug logChannel $ "checking (reverse) start order for " ++ (show cr) + mx <- receiveTimeout t [ matchChan sniffer return ] + case mx of + Just SupervisedChildStarted{..} -> childRef `shouldBe` equalTo cr + _ -> liftIO $ assertFailure $ "Bad Child Start: " ++ (show mx) + +checkStartupOrder :: Context -> [Child] -> Process () +checkStartupOrder Context{..} children = do + -- assert that we saw the startup sequence working... + forM_ children $ \(cr, _) -> do + debug logChannel $ "checking " ++ (show cr) + mx <- receiveTimeout (asTimeout waitTimeout) [ matchChan sniffer return ] + case mx of + Just SupervisedChildStarted{..} -> childRef `shouldBe` equalTo cr + _ -> liftIO $ assertFailure $ "Bad Child Start: " ++ (show mx) + +exitIgnore :: Process () +exitIgnore = liftIO $ throwIO ChildInitIgnore + +noOp :: Process () +noOp = return () + +blockIndefinitely :: Process () +blockIndefinitely = runTestProcess noOp + +notifyMe :: ProcessId -> Process () +notifyMe me = getSelfPid >>= send me >> obedient + +sleepy :: Process () +sleepy = (sleepFor 5 Minutes) + `catchExit` (\_ (_ :: ExitReason) -> return ()) >> sleepy + +obedient :: Process () +obedient = (sleepFor 5 Minutes) + {- supervisor inserts handlers that act like we wrote: + `catchExit` (\_ (r :: ExitReason) -> do + case r of + ExitShutdown -> return () + _ -> die r) + -} + +runCore :: SendPort () -> Process () +runCore sp = (expect >>= say) `catchExit` (\_ ExitShutdown -> sendChan sp ()) + +runApp :: SendPort () -> Process () +runApp sg = do + Just pid <- whereis "core" + link pid -- if the real "core" exits first, we go too + sendChan sg () + expect >>= say + +formatMxSupervisor :: Message -> Process (Maybe String) +formatMxSupervisor msg = do + m <- unwrapMessage msg :: Process (Maybe MxSupervisor) + case m of + Nothing -> return Nothing + Just m' -> return $ Just (show m') + +$(remotable [ 'exitIgnore + , 'noOp + , 'blockIndefinitely + , 'sleepy + , 'obedient + , 'notifyMe + , 'runCore + , 'runApp + , 'formatMxSupervisor ]) + +-- test cases start here... + +normalStartStop :: ProcessId -> Process () +normalStartStop sup = do + ensureProcessIsAlive sup + void $ monitor sup + shutdown sup + sup `shouldExitWith` DiedNormal + +sequentialShutdown :: TestResult (Maybe ()) -> Process () +sequentialShutdown result = do + (sp, rp) <- newChan + (sg, rg) <- newChan + + core' <- toChildStart $ $(mkClosure 'runCore) sp + app' <- toChildStart $ $(mkClosure 'runApp) sg + let core = (permChild core') { childRegName = Just (LocalName "core") + , childStop = StopTimeout (Delay $ within 2 Seconds) + , childKey = "child-1" + } + let app = (permChild app') { childRegName = Just (LocalName "app") + , childStop = StopTimeout (Delay $ within 2 Seconds) + , childKey = "child-2" + } + + sup <- Supervisor.start restartRight + (SequentialShutdown RightToLeft) + [core, app] + + () <- receiveChan rg + exit sup ExitShutdown + res <- receiveChanTimeout (asTimeout $ seconds 5) rp + stash result res + +configuredTemporaryChildExitsWithIgnore :: + ChildStart + -> (RestartStrategy -> [ChildSpec] -> (ProcessId -> Process ()) -> Assertion) + -> Assertion +configuredTemporaryChildExitsWithIgnore cs withSupervisor = + let spec = tempWorker cs in do + withSupervisor restartOne [spec] verifyExit + where + verifyExit :: ProcessId -> Process () + verifyExit sup = do + child <- lookupChild sup "temp-worker" + case child of + Nothing -> return () -- the child exited and was removed ok + Just (ref, _) -> do + Just pid <- resolve ref + verifyTempChildWasRemoved pid sup + +configuredNonTemporaryChildExitsWithIgnore :: + ChildStart + -> (RestartStrategy -> [ChildSpec] -> (ProcessId -> Process ()) -> Assertion) + -> Assertion +configuredNonTemporaryChildExitsWithIgnore cs withSupervisor = + let spec = transientWorker cs in do + withSupervisor restartOne [spec] $ verifyExit spec + where + verifyExit :: ChildSpec -> ProcessId -> Process () + verifyExit spec sup = do + sleep $ milliSeconds 100 -- make sure our super has seen the EXIT signal + child <- lookupChild sup (childKey spec) + case child of + Nothing -> liftIO $ assertFailure $ "lost non-temp spec!" + Just (ref, spec') -> do + rRef <- resolve ref + maybe (return DiedNormal) waitForExit rRef + cSpec <- lookupChild sup (childKey spec') + case cSpec of + Just (ChildStartIgnored, _) -> return () + _ -> do + liftIO $ assertFailure $ "unexpected lookup: " ++ (show cSpec) + +startTemporaryChildExitsWithIgnore :: ChildStart -> ProcessId -> Process () +startTemporaryChildExitsWithIgnore cs sup = + -- if a temporary child exits with "ignore" then we must + -- have deleted its specification from the supervisor + let spec = tempWorker cs in do + ChildAdded ref <- startNewChild sup spec + Just pid <- resolve ref + verifyTempChildWasRemoved pid sup + +startNonTemporaryChildExitsWithIgnore :: ChildStart -> ProcessId -> Process () +startNonTemporaryChildExitsWithIgnore cs sup = + let spec = transientWorker cs in do + ChildAdded ref <- startNewChild sup spec + Just pid <- resolve ref + void $ waitForExit pid + sleep $ milliSeconds 250 + cSpec <- lookupChild sup (childKey spec) + case cSpec of + Just (ChildStartIgnored, _) -> return () + _ -> do + liftIO $ assertFailure $ "unexpected lookup: " ++ (show cSpec) + +addChildWithoutRestart :: ChildStart -> ProcessId -> Process () +addChildWithoutRestart cs sup = + let spec = transientWorker cs in do + response <- addChild sup spec + response `shouldBe` equalTo (ChildAdded ChildStopped) + +addChildThenStart :: ChildStart -> ProcessId -> Process () +addChildThenStart cs sup = + let spec = transientWorker cs in do + (ChildAdded _) <- addChild sup spec + response <- startChild sup (childKey spec) + case response of + ChildStartOk (ChildRunning pid) -> do + alive <- isProcessAlive pid + alive `shouldBe` equalTo True + _ -> do + liftIO $ putStrLn (show response) + die "Ooops" + +startUnknownChild :: ChildStart -> ProcessId -> Process () +startUnknownChild cs sup = do + response <- startChild sup (childKey (transientWorker cs)) + response `shouldBe` equalTo ChildStartUnknownId + +setupChild :: ChildStart -> ProcessId -> Process (ChildRef, ChildSpec) +setupChild cs sup = do + let spec = transientWorker cs + response <- addChild sup spec + response `shouldBe` equalTo (ChildAdded ChildStopped) + Just child <- lookupChild sup "transient-worker" + return child + +addDuplicateChild :: ChildStart -> ProcessId -> Process () +addDuplicateChild cs sup = do + (ref, spec) <- setupChild cs sup + dup <- addChild sup spec + dup `shouldBe` equalTo (ChildFailedToStart $ StartFailureDuplicateChild ref) + +startDuplicateChild :: ChildStart -> ProcessId -> Process () +startDuplicateChild cs sup = do + (ref, spec) <- setupChild cs sup + dup <- startNewChild sup spec + dup `shouldBe` equalTo (ChildFailedToStart $ StartFailureDuplicateChild ref) + +startBadClosure :: ChildStart -> ProcessId -> Process () +startBadClosure cs sup = do + let spec = tempWorker cs + child <- startNewChild sup spec + child `shouldBe` equalTo + (ChildFailedToStart $ StartFailureBadClosure + "user error (Could not resolve closure: Invalid static label 'non-existing')") + +-- configuredBadClosure withSupervisor = do +-- let spec = permChild (closure (staticLabel "non-existing") empty) +-- -- we make sure we don't hit the supervisor's limits +-- let strategy = RestartOne $ limit (maxRestarts 500000000) (milliSeconds 1) +-- withSupervisor strategy [spec] $ \sup -> do +-- -- ref <- monitor sup +-- children <- (listChildren sup) +-- let specs = map fst children +-- expectThat specs $ equalTo [] + +deleteExistingChild :: ChildStart -> ProcessId -> Process () +deleteExistingChild cs sup = do + let spec = transientWorker cs + (ChildAdded ref) <- startNewChild sup spec + result <- deleteChild sup "transient-worker" + result `shouldBe` equalTo (ChildNotStopped ref) + +deleteStoppedTempChild :: ChildStart -> ProcessId -> Process () +deleteStoppedTempChild cs sup = do + let spec = tempWorker cs + ChildAdded ref <- startNewChild sup spec + Just pid <- resolve ref + testProcessStop pid + -- child needs to be stopped + waitForExit pid + result <- deleteChild sup (childKey spec) + result `shouldBe` equalTo ChildNotFound + +deleteStoppedChild :: ChildStart -> ProcessId -> Process () +deleteStoppedChild cs sup = do + let spec = transientWorker cs + ChildAdded ref <- startNewChild sup spec + Just pid <- resolve ref + testProcessStop pid + -- child needs to be stopped + waitForExit pid + result <- deleteChild sup (childKey spec) + result `shouldBe` equalTo ChildDeleted + +permanentChildrenAlwaysRestart :: ChildStart -> ProcessId -> Process () +permanentChildrenAlwaysRestart cs sup = do + let spec = permChild cs + (ChildAdded ref) <- startNewChild sup spec + Just pid <- resolve ref + testProcessStop pid -- a normal stop should *still* trigger a restart + verifyChildWasRestarted (childKey spec) pid sup + +temporaryChildrenNeverRestart :: ChildStart -> ProcessId -> Process () +temporaryChildrenNeverRestart cs sup = do + let spec = tempWorker cs + (ChildAdded ref) <- startNewChild sup spec + Just pid <- resolve ref + kill pid "bye bye" + verifyTempChildWasRemoved pid sup + +transientChildrenNormalExit :: ChildStart -> ProcessId -> Process () +transientChildrenNormalExit cs sup = do + let spec = transientWorker cs + (ChildAdded ref) <- startNewChild sup spec + Just pid <- resolve ref + testProcessStop pid + verifyChildWasNotRestarted (childKey spec) pid sup + +transientChildrenAbnormalExit :: ChildStart -> ProcessId -> Process () +transientChildrenAbnormalExit cs sup = do + let spec = transientWorker cs + (ChildAdded ref) <- startNewChild sup spec + Just pid <- resolve ref + kill pid "bye bye" + verifyChildWasRestarted (childKey spec) pid sup + +transientChildrenExitShutdown :: ChildStart -> Context -> Process () +transientChildrenExitShutdown cs Context{..} = do + let spec = transientWorker cs + (ChildAdded ref) <- startNewChild sup spec + + Just _ <- receiveChanTimeout (asTimeout waitTimeout) sniffer :: Process (Maybe MxSupervisor) + + Just pid <- resolve ref + mRef <- monitor pid + exit pid ExitShutdown + waitForDown mRef + + mx <- receiveChanTimeout 1000 sniffer :: Process (Maybe MxSupervisor) + expectThat mx isNothing + verifyChildWasNotRestarted (childKey spec) pid sup + +intrinsicChildrenAbnormalExit :: ChildStart -> ProcessId -> Process () +intrinsicChildrenAbnormalExit cs sup = do + let spec = intrinsicWorker cs + ChildAdded ref <- startNewChild sup spec + Just pid <- resolve ref + kill pid "bye bye" + verifyChildWasRestarted (childKey spec) pid sup + +intrinsicChildrenNormalExit :: ChildStart -> ProcessId -> Process () +intrinsicChildrenNormalExit cs sup = do + let spec = intrinsicWorker cs + ChildAdded ref <- startNewChild sup spec + Just pid <- resolve ref + testProcessStop pid + reason <- waitForExit sup + expectThat reason $ equalTo DiedNormal + +explicitRestartRunningChild :: ChildStart -> ProcessId -> Process () +explicitRestartRunningChild cs sup = do + let spec = tempWorker cs + ChildAdded ref <- startNewChild sup spec + result <- restartChild sup (childKey spec) + expectThat result $ equalTo $ ChildRestartFailed (StartFailureAlreadyRunning ref) + +explicitRestartUnknownChild :: ProcessId -> Process () +explicitRestartUnknownChild sup = do + result <- restartChild sup "unknown-id" + expectThat result $ equalTo ChildRestartUnknownId + +explicitRestartRestartingChild :: ChildStart -> ProcessId -> Process () +explicitRestartRestartingChild cs sup = do + let spec = permChild cs + ChildAdded _ <- startNewChild sup spec + -- TODO: we've seen a few explosions here (presumably of the supervisor?) + -- expecially when running with +RTS -N1 - it's possible that there's a bug + -- tucked away that we haven't cracked just yet + restarted <- (restartChild sup (childKey spec)) + `catchExit` (\_ (r :: ExitReason) -> (liftIO $ putStrLn (show r)) >> + die r) + -- this is highly timing dependent, so we have to allow for both + -- possible outcomes - on a dual core machine, the first clause + -- will match approx. 1 / 200 times when running with +RTS -N + case restarted of + ChildRestartFailed (StartFailureAlreadyRunning (ChildRestarting _)) -> return () + ChildRestartFailed (StartFailureAlreadyRunning (ChildRunning _)) -> return () + other -> liftIO $ assertFailure $ "unexpected result: " ++ (show other) + +explicitRestartStoppedChild :: ChildStart -> ProcessId -> Process () +explicitRestartStoppedChild cs sup = do + let spec = transientWorker cs + let key = childKey spec + ChildAdded ref <- startNewChild sup spec + void $ stopChild sup key + restarted <- restartChild sup key + sleepFor 500 Millis + Just (ref', _) <- lookupChild sup key + expectThat ref $ isNot $ equalTo ref' + case restarted of + ChildRestartOk (ChildRunning _) -> return () + _ -> liftIO $ assertFailure $ "unexpected exit: " ++ (show restarted) + +stopChildImmediately :: ChildStart -> ProcessId -> Process () +stopChildImmediately cs sup = do + let spec = tempWorker cs + ChildAdded ref <- startNewChild sup spec +-- Just pid <- resolve ref + mRef <- monitor ref + void $ stopChild sup (childKey spec) + reason <- waitForDown mRef + expectThat reason $ equalTo $ DiedException (expectedExitReason sup) + +stoppingChildExceedsDelay :: ProcessId -> Process () +stoppingChildExceedsDelay sup = do + let spec = (tempWorker (RunClosure $(mkStaticClosure 'sleepy))) + { childStop = StopTimeout (Delay $ within 500 Millis) } + ChildAdded ref <- startNewChild sup spec +-- Just pid <- resolve ref + mRef <- monitor ref + void $ stopChild sup (childKey spec) + reason <- waitForDown mRef + expectThat reason $ equalTo $ DiedException (expectedExitReason sup) + +stoppingChildObeysDelay :: ProcessId -> Process () +stoppingChildObeysDelay sup = do + let spec = (tempWorker (RunClosure $(mkStaticClosure 'obedient))) + { childStop = StopTimeout (Delay $ within 1 Seconds) } + ChildAdded child <- startNewChild sup spec + Just pid <- resolve child + void $ monitor pid + void $ stopChild sup (childKey spec) + child `shouldExitWith` DiedNormal + +restartAfterThreeAttempts :: + ChildStart + -> (RestartStrategy -> [ChildSpec] -> (ProcessId -> Process ()) -> Assertion) + -> Assertion +restartAfterThreeAttempts cs withSupervisor = do + let spec = permChild cs + let strategy = RestartOne $ limit (maxRestarts 500) (seconds 2) + withSupervisor strategy [spec] $ \sup -> do + mapM_ (\_ -> do + [(childRef, _)] <- listChildren sup + Just pid <- resolve childRef + ref <- monitor pid + testProcessStop pid + void $ waitForDown ref) [1..3 :: Int] + [(_, _)] <- listChildren sup + return () + +delayedRestartAfterThreeAttempts :: + (RestartStrategy -> [ChildSpec] -> (Context -> Process ()) -> Assertion) + -> Assertion +delayedRestartAfterThreeAttempts withSupervisor = do + let spec = (permChild $ RunClosure $ $(mkStaticClosure 'blockIndefinitely)) + { childRestartDelay = Just (seconds 3) } + let strategy = RestartOne $ limit (maxRestarts 2) (seconds 2) + withSupervisor strategy [spec] $ \ctx@Context{..} -> do + mapM_ (\_ -> do + [(childRef, _)] <- listChildren sup + Just pid <- resolve childRef + ref <- monitor pid + testProcessStop pid + void $ waitForDown ref) [1..3 :: Int] + + Just (ref, _) <- lookupChild sup $ childKey spec + case ref of + ChildRestarting _ -> do + SupervisedChildStarted{..} <- receiveChan sniffer + childSpecKey `shouldBe` equalTo (childKey spec) + _ -> liftIO $ assertFailure $ "Unexpected ChildRef: " ++ (show ref) + + mapM_ (const $ verifySingleRestart ctx (childKey spec)) [1..3 :: Int] + + [(ref', _)] <- listChildren sup + Just pid <- resolve ref' + mRef <- monitor pid + testProcessStop pid + void $ waitForDown mRef + +permanentChildExceedsRestartsIntensity :: + ChildStart + -> (RestartStrategy -> [ChildSpec] -> (ProcessId -> Process ()) -> Assertion) + -> Assertion +permanentChildExceedsRestartsIntensity cs withSupervisor = do + let spec = permChild cs -- child that exits immediately + let strategy = RestartOne $ limit (maxRestarts 50) (seconds 2) + withSupervisor strategy [spec] $ \sup -> do + ref <- monitor sup + -- if the supervisor dies whilst the call is in-flight, + -- *this* process will exit, therefore we handle that exit reason + void $ ((startNewChild sup spec >> return ()) + `catchExit` (\_ (_ :: ExitReason) -> return ())) + reason <- waitForDown ref + expectThat reason $ equalTo $ + DiedException $ "exit-from=" ++ (show sup) ++ + ",reason=ReachedMaxRestartIntensity" + +stopChildIgnoresSiblings :: + ChildStart + -> (RestartStrategy -> [ChildSpec] -> (ProcessId -> Process ()) -> Assertion) + -> Assertion +stopChildIgnoresSiblings cs withSupervisor = do + let templ = permChild cs + let specs = [templ { childKey = (show i) } | i <- [1..3 :: Int]] + withSupervisor restartAll specs $ \sup -> do + let toStop = childKey $ head specs + Just (ref, _) <- lookupChild sup toStop + mRef <- monitor ref + stopChild sup toStop + waitForDown mRef + children <- listChildren sup + forM_ (tail $ map fst children) $ \cRef -> do + maybe (error "invalid ref") ensureProcessIsAlive =<< resolve cRef + +restartAllWithLeftToRightSeqRestarts :: + ChildStart + -> (RestartStrategy -> [ChildSpec] -> (Context -> Process ()) -> Assertion) + -> Assertion +restartAllWithLeftToRightSeqRestarts cs withSupervisor = do + let (sz, _) = randomIshSizes + let templ = permChild cs + let specs = [templ { childKey = (show i) } | i <- [1..sz :: Int]] + withSupervisor restartAll specs $ \Context{..} -> do + let toStop = childKey $ head specs + Just (ref, _) <- lookupChild sup toStop + children <- listChildren sup + Just pid <- resolve ref + kill pid "goodbye" + forM_ (map fst children) $ \cRef -> monitor cRef >>= waitForDown + forM_ (map snd children) $ \cSpec -> do + Just (ref', _) <- lookupChild sup (childKey cSpec) + maybe (error "invalid ref") ensureProcessIsAlive =<< resolve ref' + +restartLeftWithLeftToRightSeqRestarts :: + ChildStart + -> (RestartStrategy -> [ChildSpec] -> (Context -> Process ()) -> Assertion) + -> Assertion +restartLeftWithLeftToRightSeqRestarts cs withSupervisor = do + let (lSz, sptSz) = randomIshSizes + let templ = permChild cs + let specs = [templ { childKey = (show i) } | i <- [1..lSz :: Int]] + withSupervisor restartLeft specs $ \ctx@Context{..} -> do + + children <- listChildren sup + checkStartupOrder ctx children + + sniff <- monitorSupervisor sup + + let (toRestart, _notToRestart) = splitAt sptSz specs + let (restarts, survivors) = splitAt sptSz children + let toStop = childKey $ last toRestart + Just (ref, _) <- lookupChild sup toStop + Just pid <- resolve ref + kill pid "goodbye" + + forM_ (map fst restarts) $ \cRef -> monitor cRef >>= waitForDown + + -- NB: this uses a separate channel to consume the Mx events... + waitForBranchRestartComplete sniff toStop + + children' <- listChildren sup + let (restarted', _) = splitAt sptSz children' + let xs = zip [fst o | o <- restarts] restarted' + verifySeqStartOrder ctx xs toStop + + forM_ (map snd children') $ \cSpec -> do + Just (ref', _) <- lookupChild sup (childKey cSpec) + maybe (error "invalid ref") ensureProcessIsAlive =<< resolve ref' + + resolved <- forM (map fst survivors) resolve + let possibleBadRestarts = catMaybes resolved + r <- receiveTimeout (after 5 Seconds) [ + match (\(ProcessMonitorNotification _ pid' _) -> do + case (elem pid' possibleBadRestarts) of + True -> liftIO $ assertFailure $ "unexpected exit from " ++ show pid' + False -> return ()) + ] + expectThat r isNothing + +restartRightWithLeftToRightSeqRestarts :: + ChildStart + -> (RestartStrategy -> [ChildSpec] -> (ProcessId -> Process ()) -> Assertion) + -> Assertion +restartRightWithLeftToRightSeqRestarts cs withSupervisor = do + let (lSz, sptSz) = mkRandom 150 688 + let templ = permChild cs + let specs = [templ { childKey = (show i) } | i <- [1..lSz :: Int]] + withSupervisor restartRight specs $ \sup -> do + let (_notToRestart, toRestart) = splitAt sptSz specs + let toStop = childKey $ head toRestart + Just (ref, _) <- lookupChild sup toStop + Just pid <- resolve ref + children <- listChildren sup + let (survivors, children') = splitAt sptSz children + kill pid "goodbye" + forM_ (map fst children') $ \cRef -> do + mRef <- monitor cRef + waitForDown mRef + forM_ (map snd children') $ \cSpec -> do + Just (ref', _) <- lookupChild sup (childKey cSpec) + maybe (error "invalid ref") ensureProcessIsAlive =<< resolve ref' + resolved <- forM (map fst survivors) resolve + let possibleBadRestarts = catMaybes resolved + r <- receiveTimeout (after 1 Seconds) [ + match (\(ProcessMonitorNotification _ pid' _) -> do + case (elem pid' possibleBadRestarts) of + True -> liftIO $ assertFailure $ "unexpected exit from " ++ show pid' + False -> return ()) + ] + expectThat r isNothing + +restartAllWithLeftToRightRestarts :: ProcessId -> Process () +restartAllWithLeftToRightRestarts sup = do + let (lSz, _) = randomIshSizes + self <- getSelfPid + let templ = permChild $ RunClosure ($(mkClosure 'notifyMe) self) + let specs = [templ { childKey = (show i) } | i <- [1..lSz :: Int]] + -- add the specs one by one + forM_ specs $ \s -> void $ startNewChild sup s + -- assert that we saw the startup sequence working... + children <- listChildren sup + drainAllChildren children + let toStop = childKey $ head specs + Just (ref, _) <- lookupChild sup toStop + Just pid <- resolve ref + kill pid "goodbye" + -- wait for all the exit signals, so we know the children are restarting + forM_ (map fst children) $ \cRef -> do + Just mRef <- monitor cRef + receiveWait [ + matchIf (\(ProcessMonitorNotification ref' _ _) -> ref' == mRef) + (\_ -> return ()) + -- we should NOT see *any* process signalling that it has started + -- whilst waiting for all the children to be terminated + , match (\(pid' :: ProcessId) -> do + liftIO $ assertFailure $ "unexpected signal from " ++ (show pid')) + ] + -- Now assert that all the children were restarted in the same order. + -- THIS is the bit that is technically unsafe, though it's also unlikely + -- to change, since the architecture of the node controller is pivotal to CH + children' <- listChildren sup + drainAllChildren children' + let [c1, c2] = [map fst cs | cs <- [children, children']] + forM_ (zip c1 c2) $ \(p1, p2) -> expectThat p1 $ isNot $ equalTo p2 + where + drainAllChildren children = do + -- Receive all pids then verify they arrived in the correct order. + -- Any out-of-order messages (such as ProcessMonitorNotification) will + -- violate the invariant asserted below, and fail the test case + pids <- forM children $ \_ -> expect :: Process ProcessId + forM_ pids ensureProcessIsAlive + +restartAllWithRightToLeftSeqRestarts :: Context -> Process () +restartAllWithRightToLeftSeqRestarts ctx@Context{..} = do + self <- getSelfPid + let templ = permChild $ RunClosure $(mkStaticClosure 'obedient) + let specs = [templ { childKey = (show i) } | i <- [1..listSize :: Int]] + + -- add the specs one by one + forM_ specs $ \s -> do + ChildAdded ref <- startNewChild sup s + maybe (error "invalid ref") ensureProcessIsAlive =<< resolve ref + + -- assert that we saw the startup sequence working... + children <- listChildren sup + checkStartupOrder ctx children + + -- we need this before the restarts occur + sniff <- monitorSupervisor sup + + let toStop = childKey $ head specs + Just (ref, _) <- lookupChild sup toStop + Just pid <- resolve ref + kill pid "fooboo" + + -- wait for all the exit signals, so we know the children are restarting + forM_ (map fst children) $ \cRef -> monitor cRef >>= waitForDown + + -- NB: this uses a separate channel to consume the Mx events... + waitForBranchRestartComplete sniff toStop + + children' <- listChildren sup + let xs = zip [fst o | o <- children] children' + verifySeqStartOrder ctx (reverse xs) toStop + + forM_ (map snd children') $ \cSpec -> do + Just (ref', _) <- lookupChild sup (childKey cSpec) + maybe (error "invalid ref") ensureProcessIsAlive =<< resolve ref' + +expectLeftToRightRestarts :: Context -> Process () +expectLeftToRightRestarts ctx@Context{..} = do + let templ = permChild $ RunClosure $(mkStaticClosure 'obedient) + let specs = [templ { childKey = (show i) } | i <- [1..listSize :: Int]] + -- add the specs one by one + forM_ specs $ \s -> void $ startNewChild sup s + + -- assert that we saw the startup sequence working... + children <- listChildren sup + checkStartupOrder ctx children + + let toStop = childKey $ head specs + Just (ref, _) <- lookupChild sup toStop + Just pid <- resolve ref + + -- wait for all the exit signals and ensure they arrive in RightToLeft order + refs <- forM children $ \(ch, _) -> monitor ch >>= \r -> return (ch, r) + kill pid "fooboo" + + initRes <- receiveTimeout + (asTimeout $ seconds 1) + [ matchIf + (\(ProcessMonitorNotification r _ _) -> (Just r) == (snd $ head refs)) + (\sig@(ProcessMonitorNotification _ _ _) -> return sig) ] + expectThat initRes $ isJust + + forM_ (reverse (filter ((/= ref) .fst ) refs)) $ \(_, Just mRef) -> do + (ProcessMonitorNotification ref' _ _) <- expect + if ref' == mRef then (return ()) else (die "unexpected monitor signal") + +expectRightToLeftRestarts :: Bool -> Context -> Process () +expectRightToLeftRestarts rev ctx@Context{..} = do + self <- getSelfPid + let templ = permChild $ RunClosure ($(mkClosure 'notifyMe) self) + let specs = [templ { childKey = (show i) } | i <- [1..listSize :: Int]] + -- add the specs one by one + forM_ specs $ \s -> do + ChildAdded ref <- startNewChild sup s + maybe (error "invalid ref") ensureProcessIsAlive =<< resolve ref + + children <- listChildren sup + checkStartupOrder ctx children + + -- assert that we saw the startup sequence working... + let toStop = childKey $ head specs + Just (ref, _) <- lookupChild sup toStop + Just pid <- resolve ref + kill pid "fooboobarbazbub" + + -- wait for all the exit signals, so we know the children are restarting + forM_ (map fst children) $ \cRef -> monitor cRef >>= waitForDown + + restarted' <- listChildren sup + let xs = zip [fst o | o <- children] restarted' + let xs' = if rev then xs else reverse xs + -- say $ "xs = " ++ (show [(o, (cr, childKey cs)) | (o, (cr, cs)) <- xs]) + verifyStopStartOrder ctx xs' (reverse restarted') toStop + +restartLeftWhenLeftmostChildDies :: ChildStart -> ProcessId -> Process () +restartLeftWhenLeftmostChildDies cs sup = do + let spec = permChild cs + (ChildAdded ref) <- startNewChild sup spec + (ChildAdded ref2) <- startNewChild sup $ spec { childKey = "child2" } + Just pid <- resolve ref + Just pid2 <- resolve ref2 + testProcessStop pid -- a normal stop should *still* trigger a restart + verifyChildWasRestarted (childKey spec) pid sup + Just (ref3, _) <- lookupChild sup "child2" + Just pid2' <- resolve ref3 + pid2 `shouldBe` equalTo pid2' + +restartWithoutTempChildren :: ChildStart -> ProcessId -> Process () +restartWithoutTempChildren cs sup = do + (ChildAdded refTrans) <- startNewChild sup $ transientWorker cs + (ChildAdded _) <- startNewChild sup $ tempWorker cs + (ChildAdded refPerm) <- startNewChild sup $ permChild cs + Just pid2 <- resolve refTrans + Just pid3 <- resolve refPerm + + kill pid2 "foobar" + void $ waitForExit pid2 -- this wait reduces the likelihood of a race in the test + Nothing <- lookupChild sup "temp-worker" + verifyChildWasRestarted "transient-worker" pid2 sup + verifyChildWasRestarted "perm-child" pid3 sup + +restartRightWhenRightmostChildDies :: ChildStart -> ProcessId -> Process () +restartRightWhenRightmostChildDies cs sup = do + let spec = permChild cs + (ChildAdded ref2) <- startNewChild sup $ spec { childKey = "child2" } + (ChildAdded ref) <- startNewChild sup $ spec { childKey = "child1" } + [ch1, ch2] <- listChildren sup + (fst ch1) `shouldBe` equalTo ref2 + (fst ch2) `shouldBe` equalTo ref + Just pid <- resolve ref + Just pid2 <- resolve ref2 + -- ref (and therefore pid) is 'rightmost' now + testProcessStop pid -- a normal stop should *still* trigger a restart + verifyChildWasRestarted "child1" pid sup + Just (ref3, _) <- lookupChild sup "child2" + Just pid2' <- resolve ref3 + pid2 `shouldBe` equalTo pid2' + +restartLeftWithLeftToRightRestarts :: Bool -> Context -> Process () +restartLeftWithLeftToRightRestarts rev ctx@Context{..} = do + self <- getSelfPid + let templ = permChild $ RunClosure ($(mkClosure 'notifyMe) self) + let specs = [templ { childKey = (show i) } | i <- [1..listSize :: Int]] + forM_ specs $ \s -> void $ startNewChild sup s + + -- assert that we saw the startup sequence working... + children <- listChildren sup + checkStartupOrder ctx children + + let (toRestart, _) = split specs + let (restarts, _) = split children + let toStop = childKey $ last toRestart + Just (ref', _) <- lookupChild sup toStop + Just stopPid <- resolve ref' + kill stopPid "goodbye" + + -- wait for all the exit signals, so we know the children are restarting + forM_ (map fst (fst $ split children)) $ \cRef -> monitor cRef >>= waitForDown + + children' <- listChildren sup + let (restarted, notRestarted) = split children' + let restarted' = if rev then reverse restarted else restarted + let restarts' = if rev then reverse restarts else restarts + let xs = zip [fst o | o <- restarts'] restarted' + verifyStopStartOrder ctx xs restarted toStop + + let [c1, c2] = [map fst cs | cs <- [(snd $ split children), notRestarted]] + forM_ (zip c1 c2) $ \(p1, p2) -> p1 `shouldBe` equalTo p2 + +restartRightWithLeftToRightRestarts :: Bool -> Context -> Process () +restartRightWithLeftToRightRestarts rev ctx@Context{..} = do + + let templ = permChild $ RunClosure $(mkStaticClosure 'obedient) + let specs = [templ { childKey = (show i) } | i <- [1..listSize :: Int]] + forM_ specs $ \s -> void $ startNewChild sup s + + children <- listChildren sup + + -- assert that we saw the startup sequence working... + checkStartupOrder ctx children + + let (_, toRestart) = split specs + let (_, restarts) = split children + let toStop = childKey $ head toRestart + Just (ref', _) <- lookupChild sup toStop + Just stopPid <- resolve ref' + kill stopPid "goodbye" + -- wait for all the exit signals, so we know the children are restarting + forM_ (map fst (snd $ split children)) $ \cRef -> monitor cRef >>= waitForDown + + children' <- listChildren sup + let (notRestarted, restarted) = split children' + + let restarted' = if rev then reverse restarted else restarted + let restarts' = if rev then reverse restarts else restarts + let xs = zip [fst o | o <- restarts'] restarted' + verifyStopStartOrder ctx xs restarted toStop + + let [c1, c2] = [map fst cs | cs <- [(fst $ splitAt 3 children), notRestarted]] + forM_ (zip c1 c2) $ \(p1, p2) -> p1 `shouldBe` equalTo p2 + +restartRightWithRightToLeftRestarts :: Bool -> Context -> Process () +restartRightWithRightToLeftRestarts rev ctx@Context{..} = do + let templ = permChild $ RunClosure $(mkStaticClosure 'obedient) + let specs = [templ { childKey = (show i) } | i <- [1..listSize :: Int]] + forM_ specs $ \s -> void $ startNewChild sup s + + children <- listChildren sup + + -- assert that we saw the startup sequence working... + checkStartupOrder ctx children + + let (_, toRestart) = split specs + let (_, restarts) = split children + let toStop = childKey $ head toRestart + Just (ref', _) <- lookupChild sup toStop + Just stopPid <- resolve ref' + kill stopPid "goodbye" + + -- wait for all the exit signals, so we know the children are restarting + forM_ (map fst (snd $ split children)) $ \cRef -> monitor cRef >>= waitForDown + + children' <- listChildren sup + let (notRestarted, restarted) = split children' + + let (restarts', restarted') = if rev then (reverse restarts, reverse restarted) + else (restarts, restarted) + let xs = zip [fst o | o <- restarts'] restarted' + verifyStopStartOrder ctx xs (reverse restarted) toStop + + let [c1, c2] = [map fst cs | cs <- [(fst $ split children), notRestarted]] + forM_ (zip c1 c2) $ \(p1, p2) -> p1 `shouldBe` equalTo p2 + +restartLeftWithRightToLeftRestarts :: Bool -> Context -> Process () +restartLeftWithRightToLeftRestarts rev ctx@Context{..} = do + let templ = permChild $ RunClosure $(mkStaticClosure 'obedient) + let specs = [templ { childKey = (show i) } | i <- [1..listSize :: Int]] + forM_ specs $ \s -> void $ startNewChild sup s + + children <- listChildren sup + + -- assert that we saw the startup sequence working... + checkStartupOrder ctx children + + -- split off 6 children to be restarted + let (toRestart, _) = split specs + let (restarts, toSurvive) = split children + let toStop = childKey $ last toRestart + Just (ref', _) <- lookupChild sup toStop + Just stopPid <- resolve ref' + kill stopPid "test process waves goodbye...." + + -- wait for all the exit signals, so we know the children are restarting + forM_ (map fst restarts) $ \cRef -> monitor cRef >>= waitForDown + + children' <- listChildren sup + let (restarted, notRestarted) = split children' + --let xs = zip [fst o | o <- restarts] restarted + let (restarts', restarted') = if rev then (reverse restarts, reverse restarted) + else (restarts, restarted) + let xs = zip [fst o | o <- restarts'] restarted' + + verifyStopStartOrder ctx xs (reverse restarted) toStop + + let [c1, c2] = [map fst cs | cs <- [toSurvive, notRestarted]] + forM_ (zip c1 c2) $ \(p1, p2) -> p1 `shouldBe` equalTo p2 + +-- remote table definition and main + +myRemoteTable :: RemoteTable +myRemoteTable = Main.__remoteTable initRemoteTable + +withClosure :: (ChildStart -> ProcessId -> Process ()) + -> (Closure (Process ())) + -> ProcessId -> Process () +withClosure fn clj supervisor = do + cs <- toChildStart clj + fn cs supervisor + +withClosure' :: (ChildStart -> Context -> Process ()) + -> (Closure (Process ())) + -> Context + -> Process () +withClosure' fn clj ctx = do + cs <- toChildStart clj + fn cs ctx + +tests :: NT.Transport -> IO [Test] +tests transport = do + putStrLn $ concat [ "NOTICE: Branch Tests (Relying on Non-Guaranteed Message Order) " + , "Can Fail Intermittently" ] + localNode <- newLocalNode transport myRemoteTable + singleTestLock <- newMVar () + runProcess localNode $ do + void $ supervisionMonitor + {- + slog <- systemLogFile "supervisor.test.log" Debug return + addFormatter slog $(mkStaticClosure 'formatMxSupervisor) + -} + + let withSup sm = runInTestContext localNode singleTestLock sm + let withSup' sm = runInTestContext' localNode sm + let withSupervisor = runInTestContext localNode singleTestLock ParallelShutdown + let withSupervisor' = runInTestContext' localNode ParallelShutdown + return + [ testGroup "Supervisor Processes" + [ + testGroup "Starting And Adding Children" + [ + testCase "Normal (Managed Process) Supervisor Start Stop" + (withSupervisor restartOne [] normalStartStop) + , testCase "Add Child Without Starting" + (withSupervisor restartOne [] + (withClosure addChildWithoutRestart + $(mkStaticClosure 'blockIndefinitely))) + , testCase "Start Previously Added Child" + (withSupervisor restartOne [] + (withClosure addChildThenStart + $(mkStaticClosure 'blockIndefinitely))) + , testCase "Start Unknown Child" + (withSupervisor restartOne [] + (withClosure startUnknownChild + $(mkStaticClosure 'blockIndefinitely))) + , testCase "Add Duplicate Child" + (withSupervisor restartOne [] + (withClosure addDuplicateChild + $(mkStaticClosure 'blockIndefinitely))) + , testCase "Start Duplicate Child" + (withSupervisor restartOne [] + (withClosure startDuplicateChild + $(mkStaticClosure 'blockIndefinitely))) + , testCase "Started Temporary Child Exits With Ignore" + (withSupervisor restartOne [] + (withClosure startTemporaryChildExitsWithIgnore + $(mkStaticClosure 'exitIgnore))) + , testCase "Configured Temporary Child Exits With Ignore" + (configuredTemporaryChildExitsWithIgnore + (RunClosure $(mkStaticClosure 'exitIgnore)) withSupervisor) + , testCase "Start Bad Closure" + (withSupervisor restartOne [] + (withClosure startBadClosure + (closure (staticLabel "non-existing") empty))) + , testCase "Configured Bad Closure" + (configuredTemporaryChildExitsWithIgnore + (RunClosure $(mkStaticClosure 'exitIgnore)) withSupervisor) + , testCase "Started Non-Temporary Child Exits With Ignore" + (withSupervisor restartOne [] $ + (withClosure startNonTemporaryChildExitsWithIgnore + $(mkStaticClosure 'exitIgnore))) + , testCase "Configured Non-Temporary Child Exits With Ignore" + (configuredNonTemporaryChildExitsWithIgnore + (RunClosure $(mkStaticClosure 'exitIgnore)) withSupervisor) + ] + , testGroup "Stopping And Deleting Children" + [ + testCase "Delete Existing Child Fails" + (withSupervisor restartOne [] + (withClosure deleteExistingChild + $(mkStaticClosure 'blockIndefinitely))) + , testCase "Delete Stopped Temporary Child (Doesn't Exist)" + (withSupervisor restartOne [] + (withClosure deleteStoppedTempChild + $(mkStaticClosure 'blockIndefinitely))) + , testCase "Delete Stopped Child Succeeds" + (withSupervisor restartOne [] + (withClosure deleteStoppedChild + $(mkStaticClosure 'blockIndefinitely))) + , testCase "Restart Minus Dropped (Temp) Child" + (withSupervisor restartAll [] + (withClosure restartWithoutTempChildren + $(mkStaticClosure 'blockIndefinitely))) + , testCase "Sequential Shutdown Ordering" + (delayedAssertion + "expected the shutdown order to hold" + localNode (Just ()) sequentialShutdown) + ] + , testGroup "Stopping and Restarting Children" + [ + testCase "Permanent Children Always Restart (Closure)" + (withSupervisor restartOne [] + (withClosure permanentChildrenAlwaysRestart + $(mkStaticClosure 'blockIndefinitely))) + , testCase "Temporary Children Never Restart (Closure)" + (withSupervisor restartOne [] + (withClosure temporaryChildrenNeverRestart + $(mkStaticClosure 'blockIndefinitely))) + , testCase "Transient Children Do Not Restart When Exiting Normally (Closure)" + (withSupervisor restartOne [] + (withClosure transientChildrenNormalExit + $(mkStaticClosure 'blockIndefinitely))) + , testCase "Transient Children Do Restart When Exiting Abnormally (Closure)" + (withSupervisor restartOne [] + (withClosure transientChildrenAbnormalExit + $(mkStaticClosure 'blockIndefinitely))) + , testCase "ExitShutdown Is Considered Normal" + (withSupervisor' restartOne [] + (withClosure' transientChildrenExitShutdown + $(mkStaticClosure 'blockIndefinitely))) + , testCase "Intrinsic Children Do Restart When Exiting Abnormally (Closure)" + (withSupervisor restartOne [] + (withClosure intrinsicChildrenAbnormalExit + $(mkStaticClosure 'blockIndefinitely))) + , testCase (concat [ "Intrinsic Children Cause Supervisor Exits " + , "When Exiting Normally (Closure)"]) + (withSupervisor restartOne [] + (withClosure intrinsicChildrenNormalExit + $(mkStaticClosure 'blockIndefinitely))) + , testCase "Explicit Restart Of Running Child Fails (Closure)" + (withSupervisor restartOne [] + (withClosure explicitRestartRunningChild + $(mkStaticClosure 'blockIndefinitely))) + , testCase "Explicit Restart Of Unknown Child Fails" + (withSupervisor restartOne [] explicitRestartUnknownChild) + , testCase "Explicit Restart Whilst Child Restarting Fails (Closure)" + (withSupervisor + (RestartOne (limit (maxRestarts 500000000) (milliSeconds 1))) [] + (withClosure explicitRestartRestartingChild $(mkStaticClosure 'noOp))) + , testCase "Explicit Restart Stopped Child (Closure)" + (withSupervisor restartOne [] + (withClosure explicitRestartStoppedChild + $(mkStaticClosure 'blockIndefinitely))) + , testCase "Immediate Child Stop (Brutal Kill) (Closure)" + (withSupervisor restartOne [] + (withClosure stopChildImmediately + $(mkStaticClosure 'blockIndefinitely))) + , testCase "Child Stop Exceeds Timeout/Delay (Becomes Brutal Kill)" + (withSupervisor restartOne [] stoppingChildExceedsDelay) + , testCase "Child Stop Within Timeout/Delay" + (withSupervisor restartOne [] stoppingChildObeysDelay) + ] + -- TODO: test for init failures (expecting $ ChildInitFailed r) + , testGroup "Branch Restarts" + [ + testGroup "Restart All" + [ + testCase "Stop Child Ignores Siblings" + (stopChildIgnoresSiblings + (RunClosure $(mkStaticClosure 'blockIndefinitely)) + withSupervisor) + , testCase "Restart All, Left To Right (Sequential) Restarts" + (restartAllWithLeftToRightSeqRestarts + (RunClosure $(mkStaticClosure 'blockIndefinitely)) + withSupervisor') + , testCase "Restart All, Right To Left (Sequential) Restarts" + (withSupervisor' + (RestartAll defaultLimits (RestartEach RightToLeft)) [] + restartAllWithRightToLeftSeqRestarts) + , testCase "Restart All, Left To Right Stop, Left To Right Start" + (withSup + (SequentialShutdown LeftToRight) + (RestartAll defaultLimits (RestartInOrder LeftToRight)) [] + restartAllWithLeftToRightRestarts) + , testCase "Restart All, Right To Left Stop, Right To Left Start" + (withSup' + (SequentialShutdown RightToLeft) + (RestartAll defaultLimits (RestartInOrder RightToLeft) + ) [] + (expectRightToLeftRestarts False)) + , testCase "Restart All, Left To Right Stop, Reverse Start" + (withSup' + (SequentialShutdown LeftToRight) + (RestartAll defaultLimits (RestartRevOrder LeftToRight) + ) [] + (expectRightToLeftRestarts True)) + , testCase "Restart All, Right To Left Stop, Reverse Start" + (withSup' + (SequentialShutdown RightToLeft) + (RestartAll defaultLimits (RestartRevOrder RightToLeft) + ) [] + expectLeftToRightRestarts) + ], + testGroup "Restart Left" + [ + testCase "Restart Left, Left To Right (Sequential) Restarts" + (restartLeftWithLeftToRightSeqRestarts + (RunClosure $(mkStaticClosure 'blockIndefinitely)) + withSupervisor') + , testCase "Restart Left, Leftmost Child Dies" + (withSupervisor restartLeft [] $ + restartLeftWhenLeftmostChildDies + (RunClosure $(mkStaticClosure 'blockIndefinitely))) + , testCase "Restart Left, Left To Right Stop, Left To Right Start" + (withSupervisor' + (RestartLeft defaultLimits (RestartInOrder LeftToRight)) [] + (restartLeftWithLeftToRightRestarts False)) + , testCase "Restart Left, Right To Left Stop, Right To Left Start" + (withSupervisor' + (RestartLeft defaultLimits (RestartInOrder RightToLeft)) [] + (restartLeftWithRightToLeftRestarts True)) + , testCase "Restart Left, Left To Right Stop, Reverse Start" + (withSupervisor' + (RestartLeft defaultLimits (RestartRevOrder LeftToRight)) [] + (restartLeftWithRightToLeftRestarts False)) + , testCase "Restart Left, Right To Left Stop, Reverse Start" + (withSupervisor' + (RestartLeft defaultLimits (RestartRevOrder RightToLeft)) [] + (restartLeftWithLeftToRightRestarts True)) + ], + testGroup "Restart Right" + [ + testCase "Restart Right, Left To Right (Sequential) Restarts" + (restartRightWithLeftToRightSeqRestarts + (RunClosure $(mkStaticClosure 'blockIndefinitely)) + withSupervisor) + , testCase "Restart Right, Rightmost Child Dies" + (withSupervisor restartRight [] $ + restartRightWhenRightmostChildDies + (RunClosure $(mkStaticClosure 'blockIndefinitely))) + , testCase "Restart Right, Left To Right Stop, Left To Right Start" + (withSupervisor' + (RestartRight defaultLimits (RestartInOrder LeftToRight)) [] + (restartRightWithLeftToRightRestarts False)) + , testCase "Restart Right, Right To Left Stop, Right To Left Start" + (withSupervisor' + (RestartRight defaultLimits (RestartInOrder RightToLeft)) [] + (restartRightWithRightToLeftRestarts True)) + , testCase "Restart Right, Left To Right Stop, Reverse Start" + (withSupervisor' + (RestartRight defaultLimits (RestartRevOrder LeftToRight)) [] + (restartRightWithRightToLeftRestarts False)) + , testCase "Restart Right, Right To Left Stop, Reverse Start" + (withSupervisor' + (RestartRight defaultLimits (RestartRevOrder RightToLeft)) [] + (restartRightWithLeftToRightRestarts True)) + ] + ] + , testGroup "Restart Intensity" + [ + testCase "Three Attempts Before Successful Restart" + (restartAfterThreeAttempts + (RunClosure $(mkStaticClosure 'blockIndefinitely)) withSupervisor) + , testCase "Permanent Child Exceeds Restart Limits" + (permanentChildExceedsRestartsIntensity + (RunClosure $(mkStaticClosure 'noOp)) withSupervisor) + , testCase "Permanent Child Delayed Restart" + (delayedRestartAfterThreeAttempts withSupervisor') + ] + ] +{- , testGroup "CI" + [ testCase "Flush [NonTest]" + (withSupervisor' + (RestartRight defaultLimits (RestartInOrder LeftToRight)) [] + (\_ -> sleep $ seconds 20)) + ] +-} + ] + +main :: IO () +main = testMain $ tests diff --git a/packages/distributed-process-supervisor/tests/TestUtils.hs b/packages/distributed-process-supervisor/tests/TestUtils.hs new file mode 100644 index 00000000..7448b4cb --- /dev/null +++ b/packages/distributed-process-supervisor/tests/TestUtils.hs @@ -0,0 +1,233 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveGeneric #-} + +module TestUtils + ( TestResult + -- ping ! + , Ping(Ping) + , ping + , shouldBe + , shouldMatch + , shouldContain + , shouldNotContain + , shouldExitWith + , expectThat + -- test process utilities + , TestProcessControl + , startTestProcess + , runTestProcess + , testProcessGo + , testProcessStop + , testProcessReport + , delayedAssertion + , assertComplete + , waitForExit + -- logging + , Logger() + , newLogger + , putLogMsg + , stopLogger + -- runners + , mkNode + , tryRunProcess + , testMain + , stash + ) where + +import Control.Concurrent + ( ThreadId + , myThreadId + , forkIO + ) +import Control.Concurrent.STM + ( TQueue + , newTQueueIO + , readTQueue + , writeTQueue + ) +import Control.Concurrent.MVar + ( MVar + , newEmptyMVar + , takeMVar + , putMVar + ) + +import Control.Distributed.Process hiding (catch, finally) +import Control.Distributed.Process.Node +import Control.Distributed.Process.Serializable() +import Control.Distributed.Process.Extras.Time +import Control.Distributed.Process.Extras.Timer +import Control.Distributed.Process.Extras.Internal.Types +import Control.Exception (SomeException) +import qualified Control.Exception as Exception +import Control.Monad (forever) +import Control.Monad.Catch (catch) +import Control.Monad.STM (atomically) +import Control.Rematch hiding (match) +import Control.Rematch.Run +import Test.HUnit (Assertion, assertFailure) +import Test.HUnit.Base (assertBool) +import Test.Framework (Test, defaultMain) +import Control.DeepSeq + +import Network.Transport.TCP +import qualified Network.Transport as NT + +import Data.Binary +import Data.Typeable +import GHC.Generics + +--expect :: a -> Matcher a -> Process () +--expect a m = liftIO $ Rematch.expect a m + +expectThat :: a -> Matcher a -> Process () +expectThat a matcher = case res of + MatchSuccess -> return () + (MatchFailure msg) -> liftIO $ assertFailure msg + where res = runMatch matcher a + +shouldBe :: a -> Matcher a -> Process () +shouldBe = expectThat + +shouldContain :: (Show a, Eq a) => [a] -> a -> Process () +shouldContain xs x = expectThat xs $ hasItem (equalTo x) + +shouldNotContain :: (Show a, Eq a) => [a] -> a -> Process () +shouldNotContain xs x = expectThat xs $ isNot (hasItem (equalTo x)) + +shouldMatch :: a -> Matcher a -> Process () +shouldMatch = expectThat + +shouldExitWith :: (Resolvable a) => a -> DiedReason -> Process () +shouldExitWith a r = do + _ <- resolve a + d <- receiveWait [ match (\(ProcessMonitorNotification _ _ r') -> return r') ] + d `shouldBe` equalTo r + +waitForExit :: MVar ExitReason + -> Process (Maybe ExitReason) +waitForExit exitReason = do + -- we *might* end up blocked here, so ensure the test doesn't jam up! + self <- getSelfPid + tref <- killAfter (within 10 Seconds) self "testcast timed out" + tr <- liftIO $ takeMVar exitReason + cancelTimer tref + case tr of + ExitNormal -> return Nothing + other -> return $ Just other + +mkNode :: String -> IO LocalNode +mkNode port = do + Right (transport1, _) <- + createTransportExposeInternals (defaultTCPAddr "127.0.0.1" port) defaultTCPParameters + newLocalNode transport1 initRemoteTable + +-- | Run the supplied @testProc@ using an @MVar@ to collect and assert +-- against its result. Uses the supplied @note@ if the assertion fails. +delayedAssertion :: (Eq a) => String -> LocalNode -> a -> + (TestResult a -> Process ()) -> Assertion +delayedAssertion note localNode expected testProc = do + result <- newEmptyMVar + _ <- forkProcess localNode $ testProc result + assertComplete note result expected + +-- | Takes the value of @mv@ (using @takeMVar@) and asserts that it matches @a@ +assertComplete :: (Eq a) => String -> MVar a -> a -> IO () +assertComplete msg mv a = do + b <- takeMVar mv + assertBool msg (a == b) + +-- synchronised logging + +data Logger = Logger { _tid :: ThreadId, msgs :: TQueue String } + +-- | Create a new Logger. +-- Logger uses a 'TQueue' to receive and process messages on a worker thread. +newLogger :: IO Logger +newLogger = do + tid <- liftIO $ myThreadId + q <- liftIO $ newTQueueIO + _ <- forkIO $ logger q + return $ Logger tid q + where logger q' = forever $ do + msg <- atomically $ readTQueue q' + putStrLn msg + +-- | Send a message to the Logger +putLogMsg :: Logger -> String -> Process () +putLogMsg logger msg = liftIO $ atomically $ writeTQueue (msgs logger) msg + +-- | Stop the worker thread for the given Logger +stopLogger :: Logger -> IO () +stopLogger = (flip Exception.throwTo) Exception.ThreadKilled . _tid + +-- | Given a @builder@ function, make and run a test suite on a single transport +testMain :: (NT.Transport -> IO [Test]) -> IO () +testMain builder = do + Right (transport, _) <- createTransportExposeInternals (defaultTCPAddr "127.0.0.1" "0") defaultTCPParameters + testData <- builder transport + defaultMain testData + +-- | Runs a /test process/ around the supplied @proc@, which is executed +-- whenever the outer process loop receives a 'Go' signal. +runTestProcess :: Process () -> Process () +runTestProcess proc = do + ctl <- expect + case ctl of + Stop -> return () + Go -> proc >> runTestProcess proc + Report p -> receiveWait [matchAny (\m -> forward m p)] >> runTestProcess proc + +-- | Starts a test process on the local node. +startTestProcess :: Process () -> Process ProcessId +startTestProcess proc = + spawnLocal $ do + getSelfPid >>= register "test-process" + runTestProcess proc + +-- | Control signals used to manage /test processes/ +data TestProcessControl = Stop | Go | Report ProcessId + deriving (Typeable, Generic) + +instance Binary TestProcessControl where + +-- | A mutable cell containing a test result. +type TestResult a = MVar a + +-- | Stashes a value in our 'TestResult' using @putMVar@ +stash :: TestResult a -> a -> Process () +stash mvar x = liftIO $ putMVar mvar x + +-- | Tell a /test process/ to stop (i.e., 'terminate') +testProcessStop :: ProcessId -> Process () +testProcessStop pid = send pid Stop + +-- | Tell a /test process/ to continue executing +testProcessGo :: ProcessId -> Process () +testProcessGo pid = send pid Go + +-- | A simple @Ping@ signal +data Ping = Ping + deriving (Typeable, Generic, Eq, Show) + +instance Binary Ping where +instance NFData Ping where + +ping :: ProcessId -> Process () +ping pid = send pid Ping + + +tryRunProcess :: LocalNode -> Process () -> IO () +tryRunProcess node p = do + tid <- liftIO myThreadId + runProcess node $ catch p (\e -> liftIO $ Exception.throwTo tid (e::SomeException)) + +-- | Tell a /test process/ to send a report (message) +-- back to the calling process +testProcessReport :: ProcessId -> Process () +testProcessReport pid = do + self <- getSelfPid + send pid $ Report self diff --git a/packages/distributed-process-systest/ChangeLog b/packages/distributed-process-systest/ChangeLog new file mode 100644 index 00000000..10603f9f --- /dev/null +++ b/packages/distributed-process-systest/ChangeLog @@ -0,0 +1,18 @@ +2024-03-26 David Simmons-Duffin 0.3.1 + +* Relaxed upper bounds to build with ghc-9.8 +* Fixed syntax errors with Haskell2010 + +2018-11-10 Tim Watson 0.3.0 + +* Relaxed upper bounds to allow for newer versions of exceptions +* Support for GHC 8.2 (thanks agentm) +* further relax upper bounds for HUnit (thanks Alexander Vershilov) + +2017-02-05 Tim Watson 0.1.1 + +* Bugfix: relax upper bounds for HUnit + +2017-02-04 Tim Watson 0.1.0 + +* Initial Release diff --git a/packages/distributed-process-systest/LICENSE b/packages/distributed-process-systest/LICENSE new file mode 100644 index 00000000..03cf3717 --- /dev/null +++ b/packages/distributed-process-systest/LICENSE @@ -0,0 +1,31 @@ +Copyright Tim Watson, 2016 + +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. + diff --git a/packages/distributed-process-systest/distributed-process-systest.cabal b/packages/distributed-process-systest/distributed-process-systest.cabal new file mode 100644 index 00000000..479d5394 --- /dev/null +++ b/packages/distributed-process-systest/distributed-process-systest.cabal @@ -0,0 +1,58 @@ +cabal-version: 3.0 +name: distributed-process-systest +version: 0.3.1 +synopsis: Cloud Haskell Test Support +description: Testing Frameworks and Capabilities for programs built on Cloud Haskell +homepage: http://github.com/haskell-distributed/distributed-process-systest +license: BSD-3-Clause +license-file: LICENSE +Author: Tim Watson +maintainer: The Distributed Haskell team +copyright: Tim Watson +category: Control, Cloud Haskell +build-type: Simple + +source-repository head + type: git + location: https://github.com/haskell-distributed/distributed-process-systest + +common warnings + ghc-options: -Wall + -Wcompat + -Widentities + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wredundant-constraints + -fhide-source-paths + -Wpartial-fields + +library + import: warnings + exposed-modules: Control.Distributed.Process.SysTest.Utils + Build-Depends: base >= 4.14 && < 5, + ansi-terminal >= 0.5 && < 1.1, + binary >= 0.8 && < 1.0, + bytestring >= 0.10 && < 0.13, + distributed-process >= 0.6.1 && < 0.8, + distributed-static < 0.4, + HUnit >= 1.2 && < 2, + network-transport >= 0.4.1.0 && < 0.6, + network >= 2.5 && < 3.3, + random >= 1.0 && < 1.3, + rematch >= 0.1.2.1 && < 0.3, + test-framework >= 0.6 && < 0.9, + test-framework-hunit >= 0.2.0 && < 0.4, + exceptions < 0.11, + stm < 2.6 + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall -fno-warn-unused-do-bind + default-extensions: CPP, + ExistentialQuantification, + FlexibleInstances, + DeriveDataTypeable, + DeriveGeneric, + GeneralizedNewtypeDeriving, + RankNTypes, + RecordWildCards, + ScopedTypeVariables diff --git a/packages/distributed-process-systest/src/Control/Distributed/Process/SysTest/Utils.hs b/packages/distributed-process-systest/src/Control/Distributed/Process/SysTest/Utils.hs new file mode 100644 index 00000000..435a5fae --- /dev/null +++ b/packages/distributed-process-systest/src/Control/Distributed/Process/SysTest/Utils.hs @@ -0,0 +1,229 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TemplateHaskell #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Distributed.Process.SysTest.Utils +-- Copyright : (c) Tim Watson 2014 - 2016 +-- License : BSD3 (see the file LICENSE) +-- +-- Maintainer : Tim Watson +-- Stability : experimental +-- Portability : non-portable (requires concurrency) +-- +-- This module provides basic building blocks for testing Cloud Haskell programs. +----------------------------------------------------------------------------- +module Control.Distributed.Process.SysTest.Utils + ( TestResult + -- ping ! + , Ping(Ping) + , ping + , shouldBe + , shouldMatch + , shouldContain + , shouldNotContain + , expectThat + , synchronisedAssertion + -- test process utilities + , TestProcessControl + , startTestProcess + , runTestProcess + , testProcessGo + , testProcessStop + , testProcessReport + , delayedAssertion + , assertComplete + -- logging + , Logger() + , newLogger + , putLogMsg + , stopLogger + -- runners + , tryRunProcess + , tryForkProcess + , noop + , stash + ) where + +import Control.Concurrent + ( ThreadId + , myThreadId + , forkIO + ) +import Control.Concurrent.STM + ( TQueue + , newTQueueIO + , readTQueue + , writeTQueue + ) +import Control.Concurrent.MVar + ( MVar + , newEmptyMVar + , takeMVar + ) + +import Control.Concurrent + ( throwTo + ) +import Control.Concurrent.MVar + ( putMVar + ) +import Control.Distributed.Process hiding (catch, finally) +import Control.Distributed.Process.Node +import Control.Distributed.Process.Serializable() +import Control.Monad.Catch + +import Control.Exception (AsyncException(ThreadKilled)) +import Control.Monad (forever) +import Control.Monad.STM (atomically) +import Control.Rematch hiding (match) +import Control.Rematch.Run +import Data.Binary +import Data.Typeable (Typeable) + +import Test.HUnit (Assertion, assertFailure) +import Test.HUnit.Base (assertBool) + +import GHC.Generics + +-- | A mutable cell containing a test result. +type TestResult a = MVar a + +-- | A simple @Ping@ signal +data Ping = Ping + deriving (Typeable, Generic, Eq, Show) +instance Binary Ping where + +ping :: ProcessId -> Process () +ping pid = send pid Ping + +-- | Control signals used to manage /test processes/ +data TestProcessControl = Stop | Go | Report ProcessId + deriving (Typeable, Generic) + +instance Binary TestProcessControl where + +-- | Does exactly what it says on the tin, doing so in the @Process@ monad. +noop :: Process () +noop = return () + +synchronisedAssertion :: Eq a + => String + -> LocalNode + -> a + -> (TestResult a -> Process ()) + -> MVar () + -> Assertion +synchronisedAssertion note localNode expected testProc lock = do + result <- newEmptyMVar + _ <- forkProcess localNode $ do + acquire lock + finally (testProc result) + (release lock) + assertComplete note result expected + where acquire lock' = liftIO $ takeMVar lock' + release lock' = liftIO $ putMVar lock' () + +stash :: TestResult a -> a -> Process () +stash mvar x = liftIO $ putMVar mvar x + +expectThat :: a -> Matcher a -> Process () +expectThat a matcher = case res of + MatchSuccess -> return () + (MatchFailure msg) -> liftIO $ assertFailure msg + where res = runMatch matcher a + +shouldBe :: a -> Matcher a -> Process () +shouldBe = expectThat + +shouldContain :: (Show a, Eq a) => [a] -> a -> Process () +shouldContain xs x = expectThat xs $ hasItem (equalTo x) + +shouldNotContain :: (Show a, Eq a) => [a] -> a -> Process () +shouldNotContain xs x = expectThat xs $ isNot (hasItem (equalTo x)) + +shouldMatch :: a -> Matcher a -> Process () +shouldMatch = expectThat + +-- | Run the supplied @testProc@ using an @MVar@ to collect and assert +-- against its result. Uses the supplied @note@ if the assertion fails. +delayedAssertion :: (Eq a) => String -> LocalNode -> a -> + (TestResult a -> Process ()) -> Assertion +delayedAssertion note localNode expected testProc = do + result <- newEmptyMVar + _ <- forkProcess localNode $ testProc result + assertComplete note result expected + +-- | Takes the value of @mv@ (using @takeMVar@) and asserts that it matches @a@ +assertComplete :: (Eq a) => String -> MVar a -> a -> IO () +assertComplete msg mv a = do + b <- takeMVar mv + assertBool msg (a == b) + +-- synchronised logging + +data Logger = Logger { _tid :: ThreadId, msgs :: TQueue String } + +-- | Create a new Logger. +-- Logger uses a 'TQueue' to receive and process messages on a worker thread. +newLogger :: IO Logger +newLogger = do + tid <- liftIO $ myThreadId + q <- liftIO $ newTQueueIO + _ <- forkIO $ logger q + return $ Logger tid q + where logger q' = forever $ do + msg <- atomically $ readTQueue q' + putStrLn msg + +-- | Send a message to the Logger +putLogMsg :: Logger -> String -> Process () +putLogMsg logger msg = liftIO $ atomically $ writeTQueue (msgs logger) msg + +-- | Stop the worker thread for the given Logger +stopLogger :: Logger -> IO () +stopLogger = (flip throwTo) ThreadKilled . _tid + +-- | Starts a test process on the local node. +startTestProcess :: Process () -> Process ProcessId +startTestProcess proc = + spawnLocal $ do + getSelfPid >>= register "test-process" + runTestProcess proc + +-- | Runs a /test process/ around the supplied @proc@, which is executed +-- whenever the outer process loop receives a 'Go' signal. +runTestProcess :: Process () -> Process () +runTestProcess proc = do + ctl <- expect + case ctl of + Stop -> return () + Go -> proc >> runTestProcess proc + Report p -> receiveWait [matchAny (\m -> forward m p)] >> runTestProcess proc + +-- | Tell a /test process/ to continue executing +testProcessGo :: ProcessId -> Process () +testProcessGo pid = send pid Go + +-- | Tell a /test process/ to stop (i.e., 'terminate') +testProcessStop :: ProcessId -> Process () +testProcessStop pid = send pid Stop + +-- | Tell a /test process/ to send a report (message) +-- back to the calling process +testProcessReport :: ProcessId -> Process () +testProcessReport pid = do + self <- getSelfPid + send pid $ Report self + +tryRunProcess :: LocalNode -> Process () -> IO () +tryRunProcess node p = do + tid <- liftIO myThreadId + runProcess node $ catch p (\e -> liftIO $ throwTo tid (e::SomeException)) + +tryForkProcess :: LocalNode -> Process () -> IO ProcessId +tryForkProcess node p = do + tid <- liftIO myThreadId + forkProcess node $ catch p (\e -> liftIO $ throwTo tid (e::SomeException)) + diff --git a/distributed-process-tests/.gitignore b/packages/distributed-process-tests/.gitignore similarity index 100% rename from distributed-process-tests/.gitignore rename to packages/distributed-process-tests/.gitignore diff --git a/packages/distributed-process-tests/LICENSE b/packages/distributed-process-tests/LICENSE new file mode 100644 index 00000000..f3459e44 --- /dev/null +++ b/packages/distributed-process-tests/LICENSE @@ -0,0 +1,31 @@ +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. + diff --git a/distributed-process-tests/distributed-process-tests.cabal b/packages/distributed-process-tests/distributed-process-tests.cabal similarity index 75% rename from distributed-process-tests/distributed-process-tests.cabal rename to packages/distributed-process-tests/distributed-process-tests.cabal index bad65655..59c0708f 100644 --- a/distributed-process-tests/distributed-process-tests.cabal +++ b/packages/distributed-process-tests/distributed-process-tests.cabal @@ -1,22 +1,33 @@ +cabal-version: 3.0 name: distributed-process-tests version: 0.4.12 synopsis: Tests and test support tools for distributed-process. homepage: http://github.com/haskell-distributed/distributed-process/tree/master/distributed-process-tests description: Tests and test suite for Cloud Haskell libraries. -license: BSD3 +license: BSD-3-Clause license-file: LICENSE Author: Duncan Coutts, Nicolas Wu, Edsko de Vries -Maintainer: Tim Watson +maintainer: The Distributed Haskell team copyright: Well-Typed LLP category: Control, Cloud Haskell build-type: Simple -cabal-version: >=1.10 flag tcp Description: build and run TCP tests Default: False +common warnings + ghc-options: -Wall + -Wcompat + -Widentities + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wredundant-constraints + -fhide-source-paths + -Wpartial-fields + library + import: warnings exposed-modules: Network.Transport.Test Control.Distributed.Process.Tests.CH Control.Distributed.Process.Tests.Closure @@ -25,16 +36,16 @@ library Control.Distributed.Process.Tests.Stats Control.Distributed.Process.Tests.Tracing Control.Distributed.Process.Tests.Internal.Utils - Build-Depends: base >= 4.9 && < 5, + Build-Depends: base >= 4.14 && < 5, ansi-terminal >= 0.5, - binary >= 0.5 && < 0.9, - bytestring >= 0.9 && < 0.13, + binary >= 0.8 && < 0.9, + bytestring >= 0.10 && < 0.13, distributed-process >= 0.6.0 && < 0.8, distributed-static, - exceptions >= 0.5, + exceptions >= 0.10, HUnit >= 1.2 && < 1.7, network-transport >= 0.4.1.0 && < 0.6, - network >= 2.5 && < 3.2, + network >= 2.5 && < 3.3, random >= 1.0 && < 1.3, setenv >= 0.1.1.3, test-framework >= 0.6 && < 0.9, @@ -42,7 +53,7 @@ library stm hs-source-dirs: src default-language: Haskell98 - ghc-options: -Wall -fno-warn-unused-do-bind + ghc-options: -fno-warn-unused-do-bind default-extensions: CPP, ExistentialQuantification, FlexibleInstances, @@ -52,30 +63,30 @@ library RankNTypes, RecordWildCards, ScopedTypeVariables - if impl(ghc <= 7.4.2) - Build-Depends: ghc-prim == 0.2.0.0 Test-Suite TestCHInMemory + import: warnings Type: exitcode-stdio-1.0 Main-Is: runInMemory.hs CPP-Options: -DTEST_SUITE_MODULE=Control.Distributed.Process.Tests.CH - Build-Depends: base >= 4.9 && < 5, + Build-Depends: base >= 4.14 && < 5, distributed-process-tests, - network >= 2.3 && < 3.2, + network >= 2.3 && < 3.3, network-transport >= 0.4.1.0 && < 0.6, network-transport-inmemory >= 0.5, test-framework >= 0.6 && < 0.9 default-extensions: CPP default-language: Haskell98 - ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind + ghc-options: -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind HS-Source-Dirs: tests Test-Suite TestCHInTCP + import: warnings Type: exitcode-stdio-1.0 Main-Is: runTCP.hs CPP-Options: -DTEST_SUITE_MODULE=Control.Distributed.Process.Tests.CH if flag(tcp) - Build-Depends: base >= 4.9 && < 5, + Build-Depends: base >= 4.14 && < 5, distributed-process-tests, network >= 2.5 && < 3.2, network-transport >= 0.4.1.0 && < 0.6, @@ -85,47 +96,50 @@ Test-Suite TestCHInTCP Buildable: False default-extensions: CPP default-language: Haskell98 - ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind + ghc-options: -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind HS-Source-Dirs: tests Test-Suite TestClosure + import: warnings Type: exitcode-stdio-1.0 Main-Is: runInMemory.hs CPP-Options: -DTEST_SUITE_MODULE=Control.Distributed.Process.Tests.Closure - Build-Depends: base >= 4.9 && < 5, + Build-Depends: base >= 4.14 && < 5, distributed-process-tests, - network >= 2.3 && < 3.2, + network >= 2.3 && < 3.3, network-transport >= 0.4.1.0 && < 0.6, network-transport-inmemory >= 0.5, test-framework >= 0.6 && < 0.9 default-extensions: CPP default-language: Haskell98 - ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind + ghc-options: -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind HS-Source-Dirs: tests Test-Suite TestStats + import: warnings Type: exitcode-stdio-1.0 Main-Is: runInMemory.hs CPP-Options: -DTEST_SUITE_MODULE=Control.Distributed.Process.Tests.Stats - Build-Depends: base >= 4.9 && < 5, + Build-Depends: base >= 4.14 && < 5, distributed-process-tests, - network >= 2.3 && < 3.2, + network >= 2.3 && < 3.3, network-transport >= 0.4.1.0 && < 0.6, network-transport-inmemory >= 0.5, test-framework >= 0.6 && < 0.9 default-extensions: CPP default-language: Haskell98 - ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind + ghc-options: -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind HS-Source-Dirs: tests Test-Suite TestMxInMemory + import: warnings Type: exitcode-stdio-1.0 Main-Is: runInMemory.hs CPP-Options: -DTEST_SUITE_MODULE=Control.Distributed.Process.Tests.Mx - Build-Depends: base >= 4.9 && < 5, + Build-Depends: base >= 4.14 && < 5, distributed-process-tests, - network >= 2.3 && < 3.2, + network >= 2.3 && < 3.3, network-transport >= 0.4.1.0 && < 0.6, network-transport-inmemory >= 0.5, test-framework >= 0.6 && < 0.9 @@ -135,12 +149,13 @@ Test-Suite TestMxInMemory HS-Source-Dirs: tests Test-Suite TestTracingInMemory + import: warnings Type: exitcode-stdio-1.0 Main-Is: runInMemory.hs CPP-Options: -DTEST_SUITE_MODULE=Control.Distributed.Process.Tests.Tracing - Build-Depends: base >= 4.9 && < 5, + Build-Depends: base >= 4.14 && < 5, distributed-process-tests, - network >= 2.3 && < 3.2, + network >= 2.3 && < 3.3, network-transport >= 0.4.1.0 && < 0.6, network-transport-inmemory >= 0.5, test-framework >= 0.6 && < 0.9 @@ -150,16 +165,17 @@ Test-Suite TestTracingInMemory HS-Source-Dirs: tests Test-Suite TestMxInTCP + import: warnings Type: exitcode-stdio-1.0 Main-Is: runInMemory.hs CPP-Options: -DTEST_SUITE_MODULE=Control.Distributed.Process.Tests.Mx - Build-Depends: base >= 4.9 && < 5, + Build-Depends: base >= 4.14 && < 5, distributed-process-tests, - network >= 2.3 && < 3.2, + network >= 2.3 && < 3.3, network-transport >= 0.4.1.0 && < 0.6, network-transport-inmemory >= 0.5, test-framework >= 0.6 && < 0.9 default-extensions: CPP default-language: Haskell98 - ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind + ghc-options: -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind HS-Source-Dirs: tests diff --git a/distributed-process-tests/src/Control/Distributed/Process/Tests/CH.hs b/packages/distributed-process-tests/src/Control/Distributed/Process/Tests/CH.hs similarity index 99% rename from distributed-process-tests/src/Control/Distributed/Process/Tests/CH.hs rename to packages/distributed-process-tests/src/Control/Distributed/Process/Tests/CH.hs index 358f6176..e5f823c5 100644 --- a/distributed-process-tests/src/Control/Distributed/Process/Tests/CH.hs +++ b/packages/distributed-process-tests/src/Control/Distributed/Process/Tests/CH.hs @@ -1,8 +1,5 @@ module Control.Distributed.Process.Tests.CH (tests) where -#if ! MIN_VERSION_base(4,6,0) -import Prelude hiding (catch) -#endif import Network.Transport.Test (TestTransport(..)) @@ -1852,10 +1849,10 @@ tests testtrans = return [ ] -- Tests that fail occasionally and should be revised - , testGroup "Flaky" [ - testCase "Reconnect" (testReconnect testtrans) - , testCase "Registry" (testRegistry testtrans) - , testCase "MergeChannels" (testMergeChannels testtrans) - , testCase "MonitorUnreachable" (testMonitorUnreachable testtrans True False) - ] + -- , testGroup "Flaky" [ + -- testCase "Reconnect" (testReconnect testtrans) + -- , testCase "Registry" (testRegistry testtrans) + -- , testCase "MergeChannels" (testMergeChannels testtrans) + -- , testCase "MonitorUnreachable" (testMonitorUnreachable testtrans True False) + -- ] ] diff --git a/distributed-process-tests/src/Control/Distributed/Process/Tests/Closure.hs b/packages/distributed-process-tests/src/Control/Distributed/Process/Tests/Closure.hs similarity index 100% rename from distributed-process-tests/src/Control/Distributed/Process/Tests/Closure.hs rename to packages/distributed-process-tests/src/Control/Distributed/Process/Tests/Closure.hs diff --git a/distributed-process-tests/src/Control/Distributed/Process/Tests/Internal/Utils.hs b/packages/distributed-process-tests/src/Control/Distributed/Process/Tests/Internal/Utils.hs similarity index 98% rename from distributed-process-tests/src/Control/Distributed/Process/Tests/Internal/Utils.hs rename to packages/distributed-process-tests/src/Control/Distributed/Process/Tests/Internal/Utils.hs index e1b935b2..06aa71e9 100644 --- a/distributed-process-tests/src/Control/Distributed/Process/Tests/Internal/Utils.hs +++ b/packages/distributed-process-tests/src/Control/Distributed/Process/Tests/Internal/Utils.hs @@ -45,9 +45,6 @@ module Control.Distributed.Process.Tests.Internal.Utils , stash ) where -#if ! MIN_VERSION_base(4,6,0) -import Prelude hiding (catch) -#endif import Control.Concurrent ( ThreadId , myThreadId diff --git a/distributed-process-tests/src/Control/Distributed/Process/Tests/Mx.hs b/packages/distributed-process-tests/src/Control/Distributed/Process/Tests/Mx.hs similarity index 99% rename from distributed-process-tests/src/Control/Distributed/Process/Tests/Mx.hs rename to packages/distributed-process-tests/src/Control/Distributed/Process/Tests/Mx.hs index 18d55ca3..816db02a 100644 --- a/distributed-process-tests/src/Control/Distributed/Process/Tests/Mx.hs +++ b/packages/distributed-process-tests/src/Control/Distributed/Process/Tests/Mx.hs @@ -40,9 +40,6 @@ import Data.List (find, sort, intercalate) import Data.Maybe (isJust, fromJust, isNothing, fromMaybe, catMaybes) import Data.Typeable import GHC.Generics hiding (from) -#if ! MIN_VERSION_base(4,6,0) -import Prelude hiding (catch, log) -#endif import Test.Framework ( Test diff --git a/distributed-process-tests/src/Control/Distributed/Process/Tests/Receive.hs b/packages/distributed-process-tests/src/Control/Distributed/Process/Tests/Receive.hs similarity index 100% rename from distributed-process-tests/src/Control/Distributed/Process/Tests/Receive.hs rename to packages/distributed-process-tests/src/Control/Distributed/Process/Tests/Receive.hs diff --git a/distributed-process-tests/src/Control/Distributed/Process/Tests/Stats.hs b/packages/distributed-process-tests/src/Control/Distributed/Process/Tests/Stats.hs similarity index 98% rename from distributed-process-tests/src/Control/Distributed/Process/Tests/Stats.hs rename to packages/distributed-process-tests/src/Control/Distributed/Process/Tests/Stats.hs index 2784e2ca..bb98afdd 100644 --- a/distributed-process-tests/src/Control/Distributed/Process/Tests/Stats.hs +++ b/packages/distributed-process-tests/src/Control/Distributed/Process/Tests/Stats.hs @@ -16,10 +16,6 @@ import Control.Distributed.Process.Node import Data.Binary () import Data.Typeable () -#if ! MIN_VERSION_base(4,6,0) -import Prelude hiding (catch) -#endif - import Test.Framework ( Test , testGroup diff --git a/distributed-process-tests/src/Control/Distributed/Process/Tests/Tracing.hs b/packages/distributed-process-tests/src/Control/Distributed/Process/Tests/Tracing.hs similarity index 99% rename from distributed-process-tests/src/Control/Distributed/Process/Tests/Tracing.hs rename to packages/distributed-process-tests/src/Control/Distributed/Process/Tests/Tracing.hs index 8880f37b..9813447b 100644 --- a/distributed-process-tests/src/Control/Distributed/Process/Tests/Tracing.hs +++ b/packages/distributed-process-tests/src/Control/Distributed/Process/Tests/Tracing.hs @@ -23,11 +23,7 @@ import Control.Distributed.Process.Management import qualified Control.Exception as IO (bracket) import Data.List (isPrefixOf, isSuffixOf) -#if ! MIN_VERSION_base(4,6,0) -import Prelude hiding (catch, log) -#else import Prelude hiding ((<*)) -#endif import Test.Framework ( Test diff --git a/distributed-process-tests/src/Network/Transport/Test.hs b/packages/distributed-process-tests/src/Network/Transport/Test.hs similarity index 100% rename from distributed-process-tests/src/Network/Transport/Test.hs rename to packages/distributed-process-tests/src/Network/Transport/Test.hs diff --git a/distributed-process-tests/tests/runInMemory.hs b/packages/distributed-process-tests/tests/runInMemory.hs similarity index 100% rename from distributed-process-tests/tests/runInMemory.hs rename to packages/distributed-process-tests/tests/runInMemory.hs diff --git a/distributed-process-tests/tests/runTCP.hs b/packages/distributed-process-tests/tests/runTCP.hs similarity index 100% rename from distributed-process-tests/tests/runTCP.hs rename to packages/distributed-process-tests/tests/runTCP.hs diff --git a/ChangeLog b/packages/distributed-process/ChangeLog similarity index 100% rename from ChangeLog rename to packages/distributed-process/ChangeLog diff --git a/LICENSE b/packages/distributed-process/LICENSE similarity index 100% rename from LICENSE rename to packages/distributed-process/LICENSE diff --git a/benchmarks/Channels.hs b/packages/distributed-process/benchmarks/Channels.hs similarity index 100% rename from benchmarks/Channels.hs rename to packages/distributed-process/benchmarks/Channels.hs diff --git a/benchmarks/Latency.hs b/packages/distributed-process/benchmarks/Latency.hs similarity index 100% rename from benchmarks/Latency.hs rename to packages/distributed-process/benchmarks/Latency.hs diff --git a/benchmarks/ProcessRing.hs b/packages/distributed-process/benchmarks/ProcessRing.hs similarity index 100% rename from benchmarks/ProcessRing.hs rename to packages/distributed-process/benchmarks/ProcessRing.hs diff --git a/benchmarks/Spawns.hs b/packages/distributed-process/benchmarks/Spawns.hs similarity index 100% rename from benchmarks/Spawns.hs rename to packages/distributed-process/benchmarks/Spawns.hs diff --git a/benchmarks/Throughput.hs b/packages/distributed-process/benchmarks/Throughput.hs similarity index 100% rename from benchmarks/Throughput.hs rename to packages/distributed-process/benchmarks/Throughput.hs diff --git a/benchmarks/erlang/latency.erl b/packages/distributed-process/benchmarks/erlang/latency.erl similarity index 100% rename from benchmarks/erlang/latency.erl rename to packages/distributed-process/benchmarks/erlang/latency.erl diff --git a/benchmarks/erlang/ring.erl b/packages/distributed-process/benchmarks/erlang/ring.erl similarity index 100% rename from benchmarks/erlang/ring.erl rename to packages/distributed-process/benchmarks/erlang/ring.erl diff --git a/benchmarks/erlang/throughput.erl b/packages/distributed-process/benchmarks/erlang/throughput.erl similarity index 100% rename from benchmarks/erlang/throughput.erl rename to packages/distributed-process/benchmarks/erlang/throughput.erl diff --git a/benchmarks/remote/Latency.hs b/packages/distributed-process/benchmarks/remote/Latency.hs similarity index 100% rename from benchmarks/remote/Latency.hs rename to packages/distributed-process/benchmarks/remote/Latency.hs diff --git a/benchmarks/remote/Throughput.hs b/packages/distributed-process/benchmarks/remote/Throughput.hs similarity index 100% rename from benchmarks/remote/Throughput.hs rename to packages/distributed-process/benchmarks/remote/Throughput.hs diff --git a/distributed-process.cabal b/packages/distributed-process/distributed-process.cabal similarity index 65% rename from distributed-process.cabal rename to packages/distributed-process/distributed-process.cabal index e2e6b1c4..4dc2491d 100644 --- a/distributed-process.cabal +++ b/packages/distributed-process/distributed-process.cabal @@ -1,12 +1,12 @@ +cabal-version: 3.0 Name: distributed-process Version: 0.7.6 -Cabal-Version: >=1.10 Build-Type: Simple -License: BSD3 +License: BSD-3-Clause License-File: LICENSE Copyright: Well-Typed LLP, Tweag I/O Limited Author: Duncan Coutts, Nicolas Wu, Edsko de Vries -Maintainer: Tim Watson +maintainer: The Distributed Haskell team Stability: experimental Homepage: https://haskell-distributed.github.io/ Bug-Reports: https://github.com/haskell-distributed/distributed-process/issues @@ -21,10 +21,20 @@ Description: This is an implementation of Cloud Haskell, as described in You will probably also want to install a Cloud Haskell backend such as distributed-process-simplelocalnet. -Tested-With: GHC==7.10.3 GHC==8.0.2 GHC==8.2.2 GHC==8.4.4 +tested-with: GHC==8.10.7 GHC==9.0.2 GHC==9.2.8 GHC==9.4.5 GHC==9.6.4 GHC==9.8.2 GHC==9.10.1 Category: Control extra-source-files: ChangeLog +common warnings + ghc-options: -Wall + -Wcompat + -Widentities + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wredundant-constraints + -fhide-source-paths + -Wpartial-fields + Source-Repository head Type: git Location: https://github.com/haskell-distributed/distributed-process @@ -34,57 +44,52 @@ flag th description: Build with Template Haskell support default: True -flag old-locale - description: If false then depend on time >= 1.5. - . - If true then depend on time < 1.5 together with old-locale. - default: False - Library - Build-Depends: base >= 4.9 && < 5, - binary >= 0.6.3 && < 0.10, - hashable >= 1.2.0.5 && < 1.5, + import: warnings + Build-Depends: base >= 4.14 && < 5, + binary >= 0.8 && < 0.10, + hashable >= 1.2.0.5 && < 1.6, network-transport >= 0.4.1.0 && < 0.6, stm >= 2.4 && < 2.6, transformers >= 0.2 && < 0.7, mtl >= 2.0 && < 2.4, data-accessor >= 0.2 && < 0.3, - bytestring >= 0.9 && < 0.13, + bytestring >= 0.10 && < 0.13, random >= 1.0 && < 1.3, distributed-static >= 0.2 && < 0.4, rank1dynamic >= 0.1 && < 0.5, syb >= 0.3 && < 0.8, - exceptions >= 0.5, - containers >= 0.5 && < 0.7, - deepseq >= 1.3.0.1 && < 1.6 - Exposed-modules: Control.Distributed.Process, - Control.Distributed.Process.Closure, - Control.Distributed.Process.Debug, - Control.Distributed.Process.Internal.BiMultiMap, - Control.Distributed.Process.Internal.Closure.BuiltIn, - Control.Distributed.Process.Internal.Closure.Explicit, - Control.Distributed.Process.Internal.CQueue, - Control.Distributed.Process.Internal.Messaging, - Control.Distributed.Process.Internal.Primitives, - Control.Distributed.Process.Internal.Spawn, - Control.Distributed.Process.Internal.StrictContainerAccessors, - Control.Distributed.Process.Internal.StrictList, - Control.Distributed.Process.Internal.StrictMVar, - Control.Distributed.Process.Internal.Types, - Control.Distributed.Process.Internal.WeakTQueue, - Control.Distributed.Process.Management, - Control.Distributed.Process.Node, - Control.Distributed.Process.Serializable, + exceptions >= 0.10, + containers >= 0.6 && < 0.8, + deepseq >= 1.4 && < 1.6, + time >= 1.9 + Exposed-modules: Control.Distributed.Process + Control.Distributed.Process.Closure + Control.Distributed.Process.Debug + Control.Distributed.Process.Internal.BiMultiMap + Control.Distributed.Process.Internal.Closure.BuiltIn + Control.Distributed.Process.Internal.Closure.Explicit + Control.Distributed.Process.Internal.CQueue + Control.Distributed.Process.Internal.Messaging + Control.Distributed.Process.Internal.Primitives + Control.Distributed.Process.Internal.Spawn + Control.Distributed.Process.Internal.StrictContainerAccessors + Control.Distributed.Process.Internal.StrictList + Control.Distributed.Process.Internal.StrictMVar + Control.Distributed.Process.Internal.Types + Control.Distributed.Process.Internal.WeakTQueue + Control.Distributed.Process.Management + Control.Distributed.Process.Node + Control.Distributed.Process.Serializable Control.Distributed.Process.UnsafePrimitives - Control.Distributed.Process.Management.Internal.Agent, - Control.Distributed.Process.Management.Internal.Bus, - Control.Distributed.Process.Management.Internal.Types, - Control.Distributed.Process.Management.Internal.Trace.Primitives, - Control.Distributed.Process.Management.Internal.Trace.Remote, - Control.Distributed.Process.Management.Internal.Trace.Types, + Control.Distributed.Process.Management.Internal.Agent + Control.Distributed.Process.Management.Internal.Bus + Control.Distributed.Process.Management.Internal.Types + Control.Distributed.Process.Management.Internal.Trace.Primitives + Control.Distributed.Process.Management.Internal.Trace.Remote + Control.Distributed.Process.Management.Internal.Trace.Types Control.Distributed.Process.Management.Internal.Trace.Tracer default-language: Haskell2010 - ghc-options: -Wall HS-Source-Dirs: src other-extensions: BangPatterns CPP @@ -106,10 +111,6 @@ Library TypeSynonymInstances UnboxedTuples UndecidableInstances - if flag(old-locale) - Build-Depends: time < 1.5, old-locale >= 1.0 && <1.1 - else - Build-Depends: time >= 1.5 if flag(th) other-extensions: TemplateHaskell Build-Depends: template-haskell >= 2.6 @@ -119,56 +120,57 @@ Library -- Tests are in distributed-process-test package, for convenience. benchmark distributed-process-throughput + import: warnings Type: exitcode-stdio-1.0 - Build-Depends: base >= 4.9 && < 5, + Build-Depends: base >= 4.14 && < 5, distributed-process, - network-transport-tcp >= 0.3 && <= 0.81, - bytestring >= 0.9 && < 0.13, - binary >= 0.6.3 && < 0.10 + network-transport-tcp >= 0.3 && <= 0.9, + bytestring >= 0.10 && < 0.13, + binary >= 0.8 && < 0.10 Main-Is: benchmarks/Throughput.hs default-language: Haskell2010 - ghc-options: -Wall benchmark distributed-process-latency + import: warnings Type: exitcode-stdio-1.0 - Build-Depends: base >= 4.9 && < 5, + Build-Depends: base >= 4.14 && < 5, distributed-process, - network-transport-tcp >= 0.3 && <= 0.81, - bytestring >= 0.9 && < 0.13, - binary >= 0.6.3 && < 0.10 + network-transport-tcp >= 0.3 && <= 0.9, + bytestring >= 0.10 && < 0.13, + binary >= 0.8 && < 0.10 Main-Is: benchmarks/Latency.hs default-language: Haskell2010 - ghc-options: -Wall benchmark distributed-process-channels + import: warnings Type: exitcode-stdio-1.0 - Build-Depends: base >= 4.9 && < 5, + Build-Depends: base >= 4.14 && < 5, distributed-process, - network-transport-tcp >= 0.3 && <= 0.81, - bytestring >= 0.9 && < 0.13, - binary >= 0.6.3 && < 0.10 + network-transport-tcp >= 0.3 && <= 0.9, + bytestring >= 0.10 && < 0.13, + binary >= 0.8 && < 0.10 Main-Is: benchmarks/Channels.hs default-language: Haskell2010 - ghc-options: -Wall benchmark distributed-process-spawns + import: warnings Type: exitcode-stdio-1.0 - Build-Depends: base >= 4.9 && < 5, + Build-Depends: base >= 4.14 && < 5, distributed-process, - network-transport-tcp >= 0.3 && <= 0.81, - bytestring >= 0.9 && < 0.13, - binary >= 0.6.3 && < 0.10 + network-transport-tcp >= 0.3 && <= 0.9, + bytestring >= 0.10 && < 0.13, + binary >= 0.8 && < 0.10 Main-Is: benchmarks/Spawns.hs default-language: Haskell2010 - ghc-options: -Wall benchmark distributed-process-ring + import: warnings Type: exitcode-stdio-1.0 - Build-Depends: base >= 4.9 && < 5, + Build-Depends: base >= 4.14 && < 5, distributed-process, - network-transport-tcp >= 0.3 && <= 0.81, - bytestring >= 0.9 && < 0.13, - binary >= 0.6.3 && < 0.10 + network-transport-tcp >= 0.3 && <= 0.9, + bytestring >= 0.10 && < 0.13, + binary >= 0.8 && < 0.10 Main-Is: benchmarks/ProcessRing.hs default-language: Haskell2010 - ghc-options: -Wall -threaded -O2 -rtsopts + ghc-options: -threaded -O2 -rtsopts diff --git a/doc/semantics/CloudHaskellSemantics.tex b/packages/distributed-process/doc/semantics/CloudHaskellSemantics.tex similarity index 100% rename from doc/semantics/CloudHaskellSemantics.tex rename to packages/distributed-process/doc/semantics/CloudHaskellSemantics.tex diff --git a/doc/semantics/Makefile b/packages/distributed-process/doc/semantics/Makefile similarity index 100% rename from doc/semantics/Makefile rename to packages/distributed-process/doc/semantics/Makefile diff --git a/doc/semantics/references.bib b/packages/distributed-process/doc/semantics/references.bib similarity index 100% rename from doc/semantics/references.bib rename to packages/distributed-process/doc/semantics/references.bib diff --git a/hie.yaml b/packages/distributed-process/hie.yaml similarity index 100% rename from hie.yaml rename to packages/distributed-process/hie.yaml diff --git a/src/Control/Distributed/Process.hs b/packages/distributed-process/src/Control/Distributed/Process.hs similarity index 99% rename from src/Control/Distributed/Process.hs rename to packages/distributed-process/src/Control/Distributed/Process.hs index 08532fb5..ba665051 100644 --- a/src/Control/Distributed/Process.hs +++ b/packages/distributed-process/src/Control/Distributed/Process.hs @@ -322,11 +322,7 @@ import Control.Distributed.Process.Internal.Spawn ) import qualified Control.Monad.Catch as Catch -#if MIN_VERSION_base(4,6,0) import Prelude -#else -import Prelude hiding (catch) -#endif import qualified Control.Exception as Exception (onException) import Data.Accessor ((^.)) import Data.Foldable (forM_) diff --git a/src/Control/Distributed/Process/Closure.hs b/packages/distributed-process/src/Control/Distributed/Process/Closure.hs similarity index 100% rename from src/Control/Distributed/Process/Closure.hs rename to packages/distributed-process/src/Control/Distributed/Process/Closure.hs diff --git a/src/Control/Distributed/Process/Debug.hs b/packages/distributed-process/src/Control/Distributed/Process/Debug.hs similarity index 100% rename from src/Control/Distributed/Process/Debug.hs rename to packages/distributed-process/src/Control/Distributed/Process/Debug.hs diff --git a/src/Control/Distributed/Process/Internal/BiMultiMap.hs b/packages/distributed-process/src/Control/Distributed/Process/Internal/BiMultiMap.hs similarity index 100% rename from src/Control/Distributed/Process/Internal/BiMultiMap.hs rename to packages/distributed-process/src/Control/Distributed/Process/Internal/BiMultiMap.hs diff --git a/src/Control/Distributed/Process/Internal/CQueue.hs b/packages/distributed-process/src/Control/Distributed/Process/Internal/CQueue.hs similarity index 99% rename from src/Control/Distributed/Process/Internal/CQueue.hs rename to packages/distributed-process/src/Control/Distributed/Process/Internal/CQueue.hs index 889e1ff5..376e6b74 100644 --- a/src/Control/Distributed/Process/Internal/CQueue.hs +++ b/packages/distributed-process/src/Control/Distributed/Process/Internal/CQueue.hs @@ -288,11 +288,7 @@ dequeue (CQueue arrived incoming size) blockSpec matchons = mask_ $ decrementJus -- | Weak reference to a CQueue mkWeakCQueue :: CQueue a -> IO () -> IO (Weak (CQueue a)) mkWeakCQueue m@(CQueue (StrictMVar (MVar m#)) _ _) f = IO $ \s -> -#if MIN_VERSION_base(4,9,0) case mkWeak# m# m (unIO f) s of (# s1, w #) -> (# s1, Weak w #) -#else - case mkWeak# m# m f s of (# s1, w #) -> (# s1, Weak w #) -#endif queueSize :: CQueue a -> IO Int queueSize (CQueue _ _ size) = readTVarIO size diff --git a/src/Control/Distributed/Process/Internal/Closure/BuiltIn.hs b/packages/distributed-process/src/Control/Distributed/Process/Internal/Closure/BuiltIn.hs similarity index 100% rename from src/Control/Distributed/Process/Internal/Closure/BuiltIn.hs rename to packages/distributed-process/src/Control/Distributed/Process/Internal/Closure/BuiltIn.hs diff --git a/src/Control/Distributed/Process/Internal/Closure/Explicit.hs b/packages/distributed-process/src/Control/Distributed/Process/Internal/Closure/Explicit.hs similarity index 100% rename from src/Control/Distributed/Process/Internal/Closure/Explicit.hs rename to packages/distributed-process/src/Control/Distributed/Process/Internal/Closure/Explicit.hs diff --git a/src/Control/Distributed/Process/Internal/Closure/TH.hs b/packages/distributed-process/src/Control/Distributed/Process/Internal/Closure/TH.hs similarity index 100% rename from src/Control/Distributed/Process/Internal/Closure/TH.hs rename to packages/distributed-process/src/Control/Distributed/Process/Internal/Closure/TH.hs diff --git a/src/Control/Distributed/Process/Internal/Messaging.hs b/packages/distributed-process/src/Control/Distributed/Process/Internal/Messaging.hs similarity index 100% rename from src/Control/Distributed/Process/Internal/Messaging.hs rename to packages/distributed-process/src/Control/Distributed/Process/Internal/Messaging.hs diff --git a/src/Control/Distributed/Process/Internal/Primitives.hs b/packages/distributed-process/src/Control/Distributed/Process/Internal/Primitives.hs similarity index 99% rename from src/Control/Distributed/Process/Internal/Primitives.hs rename to packages/distributed-process/src/Control/Distributed/Process/Internal/Primitives.hs index 40423c9a..8598a98a 100644 --- a/src/Control/Distributed/Process/Internal/Primitives.hs +++ b/packages/distributed-process/src/Control/Distributed/Process/Internal/Primitives.hs @@ -124,19 +124,11 @@ module Control.Distributed.Process.Internal.Primitives , sendCtrlMsg ) where -#if ! MIN_VERSION_base(4,6,0) -import Prelude hiding (catch) -#endif - import Data.Binary (Binary(..), Put, Get, decode) import Data.Time.Clock (getCurrentTime, UTCTime(..)) import Data.Time.Calendar (Day(..)) import Data.Time.Format (formatTime) -#if MIN_VERSION_time(1,5,0) import Data.Time.Format (defaultTimeLocale) -#else -import System.Locale (defaultTimeLocale) -#endif import System.Timeout (timeout) import Control.Monad (when, void) import Control.Monad.Reader (ask) diff --git a/src/Control/Distributed/Process/Internal/Spawn.hs b/packages/distributed-process/src/Control/Distributed/Process/Internal/Spawn.hs similarity index 100% rename from src/Control/Distributed/Process/Internal/Spawn.hs rename to packages/distributed-process/src/Control/Distributed/Process/Internal/Spawn.hs diff --git a/src/Control/Distributed/Process/Internal/StrictContainerAccessors.hs b/packages/distributed-process/src/Control/Distributed/Process/Internal/StrictContainerAccessors.hs similarity index 100% rename from src/Control/Distributed/Process/Internal/StrictContainerAccessors.hs rename to packages/distributed-process/src/Control/Distributed/Process/Internal/StrictContainerAccessors.hs diff --git a/src/Control/Distributed/Process/Internal/StrictList.hs b/packages/distributed-process/src/Control/Distributed/Process/Internal/StrictList.hs similarity index 100% rename from src/Control/Distributed/Process/Internal/StrictList.hs rename to packages/distributed-process/src/Control/Distributed/Process/Internal/StrictList.hs diff --git a/src/Control/Distributed/Process/Internal/StrictMVar.hs b/packages/distributed-process/src/Control/Distributed/Process/Internal/StrictMVar.hs similarity index 95% rename from src/Control/Distributed/Process/Internal/StrictMVar.hs rename to packages/distributed-process/src/Control/Distributed/Process/Internal/StrictMVar.hs index 00be882a..7aefe559 100644 --- a/src/Control/Distributed/Process/Internal/StrictMVar.hs +++ b/packages/distributed-process/src/Control/Distributed/Process/Internal/StrictMVar.hs @@ -71,8 +71,4 @@ modifyMVarMasked (StrictMVar v) f = mkWeakMVar :: StrictMVar a -> IO () -> IO (Weak (StrictMVar a)) mkWeakMVar q@(StrictMVar (MVar m#)) f = IO $ \s -> -#if MIN_VERSION_base(4,9,0) - case mkWeak# m# q (unIO f) s of (# s', w #) -> (# s', Weak w #) -#else - case mkWeak# m# q f s of (# s', w #) -> (# s', Weak w #) -#endif + case mkWeak# m# q (unIO f) s of (# s', w #) -> (# s', Weak w #) \ No newline at end of file diff --git a/src/Control/Distributed/Process/Internal/Types.hs b/packages/distributed-process/src/Control/Distributed/Process/Internal/Types.hs similarity index 99% rename from src/Control/Distributed/Process/Internal/Types.hs rename to packages/distributed-process/src/Control/Distributed/Process/Internal/Types.hs index 33d1e301..126ae3b2 100644 --- a/src/Control/Distributed/Process/Internal/Types.hs +++ b/packages/distributed-process/src/Control/Distributed/Process/Internal/Types.hs @@ -118,9 +118,6 @@ import Control.Concurrent.STM.TChan (TChan) import Control.Monad.Catch (MonadThrow(..), MonadCatch(..), MonadMask(..)) import qualified Network.Transport as NT (EndPoint, EndPointAddress, Connection) import Control.Applicative -#if !MIN_VERSION_base(4,13,0) && MIN_VERSION_base(4,9,0) -import Control.Monad.Fail (MonadFail) -#endif import Control.Monad.Fix (MonadFix) import Control.Monad.Reader (MonadReader(..), ReaderT, runReaderT) import Control.Monad.IO.Class (MonadIO(..)) @@ -356,9 +353,7 @@ newtype Process a = Process { deriving ( Applicative , Functor , Monad -#if MIN_VERSION_base(4,9,0) , MonadFail -#endif , MonadFix , MonadIO , MonadReader LocalProcess @@ -372,14 +367,13 @@ instance MonadCatch Process where lproc <- ask liftIO $ catch (runLocalProcess lproc p) (runLocalProcess lproc . h) instance MonadMask Process where -#if MIN_VERSION_exceptions(0,10,0) generalBracket acquire release inner = do lproc <- ask liftIO $ generalBracket (runLocalProcess lproc acquire) (\a e -> runLocalProcess lproc $ release a e) (runLocalProcess lproc . inner) -#endif + mask p = do lproc <- ask liftIO $ mask $ \restore -> @@ -477,11 +471,7 @@ data Message = deriving (Typeable) instance NFData Message where -#if MIN_VERSION_bytestring(0,10,0) rnf (EncodedMessage _ e) = rnf e `seq` () -#else - rnf (EncodedMessage _ e) = BSL.length e `seq` () -#endif rnf (UnencodedMessage _ a) = e `seq` () where e = BSL.length (encode a) diff --git a/src/Control/Distributed/Process/Internal/WeakTQueue.hs b/packages/distributed-process/src/Control/Distributed/Process/Internal/WeakTQueue.hs similarity index 97% rename from src/Control/Distributed/Process/Internal/WeakTQueue.hs rename to packages/distributed-process/src/Control/Distributed/Process/Internal/WeakTQueue.hs index 0dbd5c5a..7fa20f0a 100644 --- a/src/Control/Distributed/Process/Internal/WeakTQueue.hs +++ b/packages/distributed-process/src/Control/Distributed/Process/Internal/WeakTQueue.hs @@ -100,8 +100,4 @@ isEmptyTQueue (TQueue read write) = do mkWeakTQueue :: TQueue a -> IO () -> IO (Weak (TQueue a)) mkWeakTQueue q@(TQueue _read (TVar write#)) f = IO $ \s -> -#if MIN_VERSION_base(4,9,0) case mkWeak# write# q (unIO f) s of (# s', w #) -> (# s', Weak w #) -#else - case mkWeak# write# q f s of (# s', w #) -> (# s', Weak w #) -#endif diff --git a/src/Control/Distributed/Process/Management.hs b/packages/distributed-process/src/Control/Distributed/Process/Management.hs similarity index 100% rename from src/Control/Distributed/Process/Management.hs rename to packages/distributed-process/src/Control/Distributed/Process/Management.hs diff --git a/src/Control/Distributed/Process/Management/Internal/Agent.hs b/packages/distributed-process/src/Control/Distributed/Process/Management/Internal/Agent.hs similarity index 100% rename from src/Control/Distributed/Process/Management/Internal/Agent.hs rename to packages/distributed-process/src/Control/Distributed/Process/Management/Internal/Agent.hs diff --git a/src/Control/Distributed/Process/Management/Internal/Bus.hs b/packages/distributed-process/src/Control/Distributed/Process/Management/Internal/Bus.hs similarity index 100% rename from src/Control/Distributed/Process/Management/Internal/Bus.hs rename to packages/distributed-process/src/Control/Distributed/Process/Management/Internal/Bus.hs diff --git a/src/Control/Distributed/Process/Management/Internal/Trace/Primitives.hs b/packages/distributed-process/src/Control/Distributed/Process/Management/Internal/Trace/Primitives.hs similarity index 100% rename from src/Control/Distributed/Process/Management/Internal/Trace/Primitives.hs rename to packages/distributed-process/src/Control/Distributed/Process/Management/Internal/Trace/Primitives.hs diff --git a/src/Control/Distributed/Process/Management/Internal/Trace/Remote.hs b/packages/distributed-process/src/Control/Distributed/Process/Management/Internal/Trace/Remote.hs similarity index 100% rename from src/Control/Distributed/Process/Management/Internal/Trace/Remote.hs rename to packages/distributed-process/src/Control/Distributed/Process/Management/Internal/Trace/Remote.hs diff --git a/src/Control/Distributed/Process/Management/Internal/Trace/Tracer.hs b/packages/distributed-process/src/Control/Distributed/Process/Management/Internal/Trace/Tracer.hs similarity index 98% rename from src/Control/Distributed/Process/Management/Internal/Trace/Tracer.hs rename to packages/distributed-process/src/Control/Distributed/Process/Management/Internal/Trace/Tracer.hs index 982bec54..1dfcf754 100644 --- a/src/Control/Distributed/Process/Management/Internal/Trace/Tracer.hs +++ b/packages/distributed-process/src/Control/Distributed/Process/Management/Internal/Trace/Tracer.hs @@ -77,10 +77,6 @@ import Data.Time.Format (formatTime) import Debug.Trace (traceEventIO) import Prelude -#if ! MIN_VERSION_base(4,6,0) -import Prelude hiding (catch) -#endif - import System.Environment (getEnv) import System.IO ( Handle @@ -91,11 +87,7 @@ import System.IO , hPutStrLn , hSetBuffering ) -#if MIN_VERSION_time(1,5,0) import Data.Time.Format (defaultTimeLocale) -#else -import System.Locale (defaultTimeLocale) -#endif import System.Mem.Weak ( Weak ) diff --git a/src/Control/Distributed/Process/Management/Internal/Trace/Types.hs b/packages/distributed-process/src/Control/Distributed/Process/Management/Internal/Trace/Types.hs similarity index 100% rename from src/Control/Distributed/Process/Management/Internal/Trace/Types.hs rename to packages/distributed-process/src/Control/Distributed/Process/Management/Internal/Trace/Types.hs diff --git a/src/Control/Distributed/Process/Management/Internal/Types.hs b/packages/distributed-process/src/Control/Distributed/Process/Management/Internal/Types.hs similarity index 100% rename from src/Control/Distributed/Process/Management/Internal/Types.hs rename to packages/distributed-process/src/Control/Distributed/Process/Management/Internal/Types.hs diff --git a/src/Control/Distributed/Process/Node.hs b/packages/distributed-process/src/Control/Distributed/Process/Node.hs similarity index 99% rename from src/Control/Distributed/Process/Node.hs rename to packages/distributed-process/src/Control/Distributed/Process/Node.hs index b46c508f..8487d894 100644 --- a/src/Control/Distributed/Process/Node.hs +++ b/packages/distributed-process/src/Control/Distributed/Process/Node.hs @@ -38,11 +38,7 @@ import qualified Data.Map as Map , foldlWithKey ) import Data.Time.Format (formatTime) -#if MIN_VERSION_time(1,5,0) import Data.Time.Format (defaultTimeLocale) -#else -import System.Locale (defaultTimeLocale) -#endif import Data.Set (Set) import qualified Data.Set as Set ( empty diff --git a/src/Control/Distributed/Process/Serializable.hs b/packages/distributed-process/src/Control/Distributed/Process/Serializable.hs similarity index 100% rename from src/Control/Distributed/Process/Serializable.hs rename to packages/distributed-process/src/Control/Distributed/Process/Serializable.hs diff --git a/src/Control/Distributed/Process/UnsafePrimitives.hs b/packages/distributed-process/src/Control/Distributed/Process/UnsafePrimitives.hs similarity index 100% rename from src/Control/Distributed/Process/UnsafePrimitives.hs rename to packages/distributed-process/src/Control/Distributed/Process/UnsafePrimitives.hs diff --git a/packages/distributed-static/ChangeLog b/packages/distributed-static/ChangeLog new file mode 100644 index 00000000..619c2dc1 --- /dev/null +++ b/packages/distributed-static/ChangeLog @@ -0,0 +1,61 @@ +2024-03-25 David Simmons-Duffin 0.3.10 + +* Relax bytestring bounds to to build with ghc-9.8. + +2019-05-12 Facundo Domínguez 0.3.9 + +* Relax bounds to to build with ghc-8.6. + +2017-08-28 Facundo Domínguez 0.3.8 + +* Remove support for ghc-7.8 and lower +* Fix build errors with ghc-8.2.1 + +2017-08-22 Facundo Domínguez 0.3.7 + +* Make nominal the role of static + +2017-08-22 Facundo Domínguez 0.3.6 + +* Move upper bound of rank1dynamic to support ghc-8.2.1. +* Remove dynamic type check in Static Binary instance. + +2016-06-01 Facundo Domínguez 0.3.5.0 + +* Add compatibility with ghc-8. + +2016-02-18 Facundo Domínguez 0.3.4.0 + +* Support static pointers. +* Update .travis.yml to drop ghc-7.4 and test ghc-7.10. +* Make Closure and Static strict data types. + +2015-06-15 Facundo Domínguez 0.3.2.0 + +* Loosen rank1dynamic bounds. +* Add NFData instances. + +2014-12-09 Tim Watson 0.3.1.0 + +* Eq and Ord instances for Closure and Static + +2014-05-30 Tim Watson 0.3.0.0 + +* Bump binary dependency + +2012-11-22 Edsko de Vries 0.2.1.1 + +* Relax package bounds to allow for Binary 0.6 + +2012-10-03 Edsko de Vries 0.2.1 + +* Add support for 'staticFlip' + +2012-08-16 Edsko de Vries 0.2 + +* Hide the 'Closure' constructor and export 'closure' instead so that we are +free to change the internal representation + +2012-08-10 Edsko de Vries 0.1 + +* Initial release diff --git a/packages/distributed-static/LICENSE b/packages/distributed-static/LICENSE new file mode 100644 index 00000000..7a956d0d --- /dev/null +++ b/packages/distributed-static/LICENSE @@ -0,0 +1,30 @@ +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. diff --git a/packages/distributed-static/distributed-static.cabal b/packages/distributed-static/distributed-static.cabal new file mode 100644 index 00000000..23a480fe --- /dev/null +++ b/packages/distributed-static/distributed-static.cabal @@ -0,0 +1,56 @@ +cabal-version: 3.0 +Name: distributed-static +Version: 0.3.10 +Synopsis: Compositional, type-safe, polymorphic static values and closures +Description: /Towards Haskell in the Cloud/ (Epstein et al, Haskell + Symposium 2011) introduces the concept of /static/ values: + values that are known at compile time. In a distributed + setting where all nodes are running the same executable, + static values can be serialized simply by transmitting a + code pointer to the value. This however requires special + compiler support, which is not yet available in ghc. We + can mimick the behaviour by keeping an explicit mapping + ('RemoteTable') from labels to values (and making sure + that all distributed nodes are using the same + 'RemoteTable'). In this module we implement this mimickry + and various extensions: type safety (including for + polymorphic static values) and compositionality. +Homepage: http://haskell-distributed.github.com +License: BSD-3-Clause +License-File: LICENSE +Author: Edsko de Vries +maintainer: The Distributed Haskell team +Bug-Reports: https://github.com/haskell-distributed/distributed-static/issues +Copyright: Well-Typed LLP +Category: Control +Build-Type: Simple +extra-source-files: ChangeLog +tested-with: GHC==8.10.7 GHC==9.0.2 GHC==9.2.8 GHC==9.4.5 GHC==9.6.4 GHC==9.8.2 GHC==9.10.1 + +Source-Repository head + Type: git + Location: https://github.com/haskell-distributed/distributed-static + +common warnings + ghc-options: -Wall + -Wcompat + -Widentities + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wredundant-constraints + -fhide-source-paths + -Wpartial-fields + +Library + import: warnings + Exposed-Modules: Control.Distributed.Static + Build-Depends: base >= 4.14 && < 5, + rank1dynamic >= 0.1 && < 0.5, + containers >= 0.6 && < 0.8, + bytestring >= 0.10 && < 0.13, + binary >= 0.8 && < 0.9, + deepseq >= 1.4 && < 1.6 + HS-Source-Dirs: src + Default-Language: Haskell2010 + Default-Extensions: DeriveDataTypeable + ScopedTypeVariables diff --git a/packages/distributed-static/src/Control/Distributed/Static.hs b/packages/distributed-static/src/Control/Distributed/Static.hs new file mode 100644 index 00000000..df833022 --- /dev/null +++ b/packages/distributed-static/src/Control/Distributed/Static.hs @@ -0,0 +1,489 @@ +-- | /Towards Haskell in the Cloud/ (Epstein et al, Haskell Symposium 2011) +-- introduces the concept of /static/ values: values that are known at compile +-- time. In a distributed setting where all nodes are running the same +-- executable, static values can be serialized simply by transmitting a code +-- pointer to the value. This however requires special compiler support, which +-- is not yet available in ghc. We can mimick the behaviour by keeping an +-- explicit mapping ('RemoteTable') from labels to values (and making sure that +-- all distributed nodes are using the same 'RemoteTable'). In this module +-- we implement this mimickry and various extensions. +-- +-- [Compositionality] +-- +-- Static values as described in the paper are not compositional: there is no +-- way to combine two static values and get a static value out of it. This +-- makes sense when interpreting static strictly as /known at compile time/, +-- but it severely limits expressiveness. However, the main motivation for +-- 'static' is not that they are known at compile time but rather that +-- /they provide a free/ 'Binary' /instance/. We therefore provide two basic +-- constructors for 'Static' values: +-- +-- > staticLabel :: String -> Static a +-- > staticApply :: Static (a -> b) -> Static a -> Static b +-- +-- The first constructor refers to a label in a 'RemoteTable'. The second +-- allows to apply a static function to a static argument, and makes 'Static' +-- compositional: once we have 'staticApply' we can implement numerous derived +-- combinators on 'Static' values (we define a few in this module; see +-- 'staticCompose', 'staticSplit', and 'staticConst'). +-- +-- [Closures] +-- +-- Closures in functional programming arise when we partially apply a function. +-- A closure is a code pointer together with a runtime data structure that +-- represents the value of the free variables of the function. A 'Closure' +-- represents these closures explicitly so that they can be serialized: +-- +-- > data Closure a = Closure (Static (ByteString -> a)) ByteString +-- +-- See /Towards Haskell in the Cloud/ for the rationale behind representing +-- the function closure environment in serialized ('ByteString') form. Any +-- static value can trivially be turned into a 'Closure' ('staticClosure'). +-- Moreover, since 'Static' is now compositional, we can also define derived +-- operators on 'Closure' values ('closureApplyStatic', 'closureApply', +-- 'closureCompose', 'closureSplit'). +-- +-- [Monomorphic example] +-- +-- Suppose we are working in the context of some distributed environment, with +-- a monadic type 'Process' representing processes, 'NodeId' representing node +-- addresses and 'ProcessId' representing process addresses. Suppose further +-- that we have a primitive +-- +-- > sendInt :: ProcessId -> Int -> Process () +-- +-- We might want to define +-- +-- > sendIntClosure :: ProcessId -> Closure (Int -> Process ()) +-- +-- In order to do that, we need a static version of 'send', and a static +-- decoder for 'ProcessId': +-- +-- > sendIntStatic :: Static (ProcessId -> Int -> Process ()) +-- > sendIntStatic = staticLabel "$send" +-- +-- > decodeProcessIdStatic :: Static (ByteString -> Int) +-- > decodeProcessIdStatic = staticLabel "$decodeProcessId" +-- +-- where of course we have to make sure to use an appropriate 'RemoteTable': +-- +-- > rtable :: RemoteTable +-- > rtable = registerStatic "$send" (toDynamic sendInt) +-- > . registerStatic "$decodeProcessId" (toDynamic (decode :: ByteString -> Int)) +-- > $ initRemoteTable +-- +-- We can now define 'sendIntClosure': +-- +-- > sendIntClosure :: ProcessId -> Closure (Int -> Process ()) +-- > sendIntClosure pid = closure decoder (encode pid) +-- > where +-- > decoder :: Static (ByteString -> Int -> Process ()) +-- > decoder = sendIntStatic `staticCompose` decodeProcessIdStatic +-- +-- [Polymorphic example] +-- +-- Suppose we wanted to define a primitive +-- +-- > sendIntResult :: ProcessId -> Closure (Process Int) -> Closure (Process ()) +-- +-- which turns a process that computes an integer into a process that computes +-- the integer and then sends it someplace else. +-- +-- We can define +-- +-- > bindStatic :: (Typeable a, Typeable b) => Static (Process a -> (a -> Process b) -> Process b) +-- > bindStatic = staticLabel "$bind" +-- +-- provided that we register this label: +-- +-- > rtable :: RemoteTable +-- > rtable = ... +-- > . registerStatic "$bind" ((>>=) :: Process ANY1 -> (ANY1 -> Process ANY2) -> Process ANY2) +-- > $ initRemoteTable +-- +-- (Note that we are using the special 'Data.Rank1Typeable.ANY1' and +-- 'Data.Rank1Typeable.ANY2' types from "Data.Rank1Typeable" to represent this +-- polymorphic value.) Once we have a static bind we can define +-- +-- > sendIntResult :: ProcessId -> Closure (Process Int) -> Closure (Process ()) +-- > sendIntResult pid cl = bindStatic `closureApplyStatic` cl `closureApply` sendIntClosure pid +-- +-- [Dealing with qualified types] +-- +-- In the above we were careful to avoid qualified types. Suppose that we have +-- instead +-- +-- > send :: Binary a => ProcessId -> a -> Process () +-- +-- If we now want to define 'sendClosure', analogous to 'sendIntClosure' above, +-- we somehow need to include the 'Binary' instance in the closure -- after +-- all, we can ship this closure someplace else, where it needs to accept an +-- 'a', /then encode it/, and send it off. In order to do this, we need to turn +-- the Binary instance into an explicit dictionary: +-- +-- > data BinaryDict a where +-- > BinaryDict :: Binary a => BinaryDict a +-- > +-- > sendDict :: BinaryDict a -> ProcessId -> a -> Process () +-- > sendDict BinaryDict = send +-- +-- Now 'sendDict' is a normal polymorphic value: +-- +-- > sendDictStatic :: Static (BinaryDict a -> ProcessId -> a -> Process ()) +-- > sendDictStatic = staticLabel "$sendDict" +-- > +-- > rtable :: RemoteTable +-- > rtable = ... +-- > . registerStatic "$sendDict" (sendDict :: BinaryDict ANY -> ProcessId -> ANY -> Process ()) +-- > $ initRemoteTable +-- +-- so that we can define +-- +-- > sendClosure :: Static (BinaryDict a) -> Process a -> Closure (a -> Process ()) +-- > sendClosure dict pid = closure decoder (encode pid) +-- > where +-- > decoder :: Static (ByteString -> a -> Process ()) +-- > decoder = (sendDictStatic `staticApply` dict) `staticCompose` decodeProcessIdStatic +-- +-- [Word of Caution] +-- +-- You should not /define/ functions on 'ANY' and co. For example, the following +-- definition of 'rtable' is incorrect: +-- +-- > rtable :: RemoteTable +-- > rtable = registerStatic "$sdictSendPort" sdictSendPort +-- > $ initRemoteTable +-- > where +-- > sdictSendPort :: SerializableDict ANY -> SerializableDict (SendPort ANY) +-- > sdictSendPort SerializableDict = SerializableDict +-- +-- This definition of 'sdictSendPort' ignores its argument completely, and +-- constructs a 'SerializableDict' for the /monomorphic/ type @SendPort ANY@, +-- which isn't what you want. Instead, you should do +-- +-- > rtable :: RemoteTable +-- > rtable = registerStatic "$sdictSendPort" (sdictSendPort :: SerializableDict ANY -> SerializableDict (SendPort ANY)) +-- > $ initRemoteTable +-- > where +-- > sdictSendPort :: forall a. SerializableDict a -> SerializableDict (SendPort a) +-- > sdictSendPort SerializableDict = SerializableDict +{-# LANGUAGE StaticPointers #-} +{-# LANGUAGE RoleAnnotations #-} +module Control.Distributed.Static + ( -- * Static values + Static + , staticLabel + , staticApply + , staticPtr + , staticApplyPtr + -- * Derived static combinators + , staticCompose + , staticSplit + , staticConst + , staticFlip + -- * Closures + , Closure + , closure + -- * Derived closure combinators + , staticClosure + , closureApplyStatic + , closureApply + , closureCompose + , closureSplit + -- * Resolution + , RemoteTable + , initRemoteTable + , registerStatic + , unstatic + , unclosure + ) where + +import Data.Binary + ( Binary(get, put) + , Put + , Get + , putWord8 + , getWord8 + , encode + , decode + ) +import Data.ByteString.Lazy (ByteString, empty) +import Data.Map (Map) +import qualified Data.Map as Map (lookup, empty, insert) +import Control.Arrow as Arrow ((***), app) +import Control.DeepSeq (NFData(rnf), force) +import Data.Rank1Dynamic (Dynamic, toDynamic, fromDynamic, dynApply) +import Data.Rank1Typeable + ( Typeable + , ANY1 + , ANY2 + , ANY3 + , ANY4 + , TypeRep + , typeOf + ) + +-- Imports necessary to support StaticPtr +import qualified GHC.Exts as GHC (Any) +import GHC.StaticPtr +import GHC.Fingerprint.Type (Fingerprint(..)) +import System.IO.Unsafe (unsafePerformIO) +import Data.Rank1Dynamic (unsafeToDynamic) +import Unsafe.Coerce (unsafeCoerce) + +-------------------------------------------------------------------------------- +-- Introducing static values -- +-------------------------------------------------------------------------------- + +-- | Static dynamic values +-- +-- In the new proposal for static, the SPT contains these 'TypeRep's. +-- In the current implemnentation however they do not, so we need to carry +-- them ourselves. This is the TypeRep of @a@, /NOT/ of @StaticPtr a@. +data SDynamic = SDynamic TypeRep (StaticPtr GHC.Any) + deriving (Typeable) + +instance Show SDynamic where + show (SDynamic typ ptr) = + let spi = staticPtrInfo ptr + (line, col) = spInfoSrcLoc spi + in concat [ "<>" + ] + +instance Eq SDynamic where + SDynamic _ ptr1 == SDynamic _ ptr2 = + staticKey ptr1 == staticKey ptr2 + +instance Ord SDynamic where + SDynamic _ ptr1 `compare` SDynamic _ ptr2 = + staticKey ptr1 `compare` staticKey ptr2 + +data StaticLabel = + StaticLabel String + | StaticApply !StaticLabel !StaticLabel + | StaticPtr SDynamic + deriving (Eq, Ord, Typeable, Show) + +instance NFData StaticLabel where + rnf (StaticLabel s) = rnf s + rnf (StaticApply a b) = rnf a `seq` rnf b + -- There are no NFData instances for TypeRep or for StaticPtr :/ + rnf (StaticPtr (SDynamic _a _b)) = () + +-- | A static value. Static is opaque; see 'staticLabel' and 'staticApply'. +newtype Static a = Static StaticLabel + deriving (Eq, Ord, Typeable, Show) + +-- Trying to 'coerce' static values will lead to unification errors +type role Static nominal + +instance NFData (Static a) where + rnf (Static s) = rnf s + +instance Binary (Static a) where + put (Static label) = putStaticLabel label + get = Static <$> getStaticLabel + +-- We don't want StaticLabel to be its own Binary instance +putStaticLabel :: StaticLabel -> Put +putStaticLabel (StaticLabel string) = + putWord8 0 >> put string +putStaticLabel (StaticApply label1 label2) = + putWord8 1 >> putStaticLabel label1 >> putStaticLabel label2 +putStaticLabel (StaticPtr (SDynamic typ ptr)) = + let Fingerprint hi lo = staticKey ptr + in putWord8 2 >> put typ >> put hi >> put lo + +getStaticLabel :: Get StaticLabel +getStaticLabel = do + header <- getWord8 + case header of + 0 -> StaticLabel <$> get + 1 -> StaticApply <$> getStaticLabel <*> getStaticLabel + 2 -> do typ <- get + hi <- get + lo <- get + let key = Fingerprint hi lo + case unsaferLookupStaticPtr key of + Nothing -> fail "StaticLabel.get: invalid pointer" + Just ptr -> return $ StaticPtr (SDynamic typ ptr) + _ -> fail "StaticLabel.get: invalid" + +-- | We need to be able to lookup keys outside of the IO monad so that we +-- can provide a 'Get' instance. +unsaferLookupStaticPtr :: StaticKey -> Maybe (StaticPtr a) +unsaferLookupStaticPtr = unsafePerformIO . unsafeLookupStaticPtr + +-- | Create a primitive static value. +-- +-- It is the responsibility of the client code to make sure the corresponding +-- entry in the 'RemoteTable' has the appropriate type. +staticLabel :: String -> Static a +staticLabel = Static . StaticLabel . force + +-- | Apply two static values +staticApply :: Static (a -> b) -> Static a -> Static b +staticApply (Static f) (Static x) = Static (StaticApply f x) + +-- | Construct a static value from a static pointer +-- +-- Since 0.3.4.0. +staticPtr :: forall a. Typeable a => StaticPtr a -> Static a +staticPtr x = Static . StaticPtr + $ SDynamic (typeOf (undefined :: a)) (unsafeCoerce x) + +-- | Apply a static pointer to a static value +-- +-- Since 0.3.4.0. +staticApplyPtr :: (Typeable a, Typeable b) + => StaticPtr (a -> b) -> Static a -> Static b +staticApplyPtr = staticApply . staticPtr + +-------------------------------------------------------------------------------- +-- Eliminating static values -- +-------------------------------------------------------------------------------- + +-- | Runtime dictionary for 'unstatic' lookups +newtype RemoteTable = RemoteTable (Map String Dynamic) + +-- | Initial remote table +initRemoteTable :: RemoteTable +initRemoteTable = + registerStatic "$compose" (toDynamic ((.) :: (ANY2 -> ANY3) -> (ANY1 -> ANY2) -> ANY1 -> ANY3)) + . registerStatic "$const" (toDynamic (const :: ANY1 -> ANY2 -> ANY1)) + . registerStatic "$split" (toDynamic ((***) :: (ANY1 -> ANY3) -> (ANY2 -> ANY4) -> (ANY1, ANY2) -> (ANY3, ANY4))) + . registerStatic "$app" (toDynamic (app :: (ANY1 -> ANY2, ANY1) -> ANY2)) + . registerStatic "$decodeEnvPair" (toDynamic (decode :: ByteString -> (ByteString, ByteString))) + . registerStatic "$flip" (toDynamic (flip :: (ANY1 -> ANY2 -> ANY3) -> ANY2 -> ANY1 -> ANY3)) + $ RemoteTable Map.empty + +-- | Register a static label +registerStatic :: String -> Dynamic -> RemoteTable -> RemoteTable +registerStatic label dyn (RemoteTable rtable) + = RemoteTable (Map.insert label dyn rtable) + +-- Pseudo-type: RemoteTable -> Static a -> a +resolveStaticLabel :: RemoteTable -> StaticLabel -> Either String Dynamic +resolveStaticLabel (RemoteTable rtable) (StaticLabel label) = + case Map.lookup label rtable of + Nothing -> Left $ "Invalid static label '" ++ label ++ "'" + Just d -> Right d +resolveStaticLabel rtable (StaticApply label1 label2) = do + f <- resolveStaticLabel rtable label1 + x <- resolveStaticLabel rtable label2 + f `dynApply` x +resolveStaticLabel _ (StaticPtr (SDynamic typ ptr)) = + return $ unsafeToDynamic typ (deRefStaticPtr ptr) + +-- | Resolve a static value +unstatic :: Typeable a => RemoteTable -> Static a -> Either String a +unstatic rtable (Static label) = do + dyn <- resolveStaticLabel rtable label + fromDynamic dyn + +-------------------------------------------------------------------------------- +-- Closures -- +-------------------------------------------------------------------------------- + +-- | A closure is a static value and an encoded environment +data Closure a = Closure !(Static (ByteString -> a)) !ByteString + deriving (Eq, Ord, Typeable, Show) + +instance Binary (Closure a) where + put (Closure st env) = put st >> put env + get = Closure <$> get <*> get + +instance NFData (Closure a) where rnf (Closure f b) = rnf f `seq` rnf b + +closure :: Static (ByteString -> a) -- ^ Decoder + -> ByteString -- ^ Encoded closure environment + -> Closure a +closure = Closure + +-- | Resolve a closure +unclosure :: Typeable a => RemoteTable -> Closure a -> Either String a +unclosure rtable (Closure dec env) = do + f <- unstatic rtable dec + return (f env) + +-- | Convert a static value into a closure. +staticClosure :: Static a -> Closure a +staticClosure dec = closure (staticConst dec) empty + +-------------------------------------------------------------------------------- +-- Predefined static values -- +-------------------------------------------------------------------------------- + +-- | Static version of ('Prelude..') +composeStatic :: Static ((b -> c) -> (a -> b) -> a -> c) +composeStatic = staticLabel "$compose" + +-- | Static version of 'const' +constStatic :: Static (a -> b -> a) +constStatic = staticLabel "$const" + +-- | Static version of ('Arrow.***') +splitStatic :: Static ((a -> b) -> (a' -> b') -> (a, a') -> (b, b')) +splitStatic = staticLabel "$split" + +-- | Static version of 'Arrow.app' +appStatic :: Static ((a -> b, a) -> b) +appStatic = staticLabel "$app" + +-- | Static version of 'flip' +flipStatic :: Static ((a -> b -> c) -> b -> a -> c) +flipStatic = staticLabel "$flip" + +-------------------------------------------------------------------------------- +-- Combinators on static values -- +-------------------------------------------------------------------------------- + +-- | Static version of ('Prelude..') +staticCompose :: Static (b -> c) -> Static (a -> b) -> Static (a -> c) +staticCompose g f = composeStatic `staticApply` g `staticApply` f + +-- | Static version of ('Control.Arrow.***') +staticSplit :: Static (a -> b) -> Static (a' -> b') -> Static ((a, a') -> (b, b')) +staticSplit f g = splitStatic `staticApply` f `staticApply` g + +-- | Static version of 'Prelude.const' +staticConst :: Static a -> Static (b -> a) +staticConst x = constStatic `staticApply` x + +-- | Static version of 'Prelude.flip' +staticFlip :: Static (a -> b -> c) -> Static (b -> a -> c) +staticFlip f = flipStatic `staticApply` f + +-------------------------------------------------------------------------------- +-- Combinators on Closures -- +-------------------------------------------------------------------------------- + +-- | Apply a static function to a closure +closureApplyStatic :: Static (a -> b) -> Closure a -> Closure b +closureApplyStatic f (Closure decoder env) = + closure (f `staticCompose` decoder) env + +decodeEnvPairStatic :: Static (ByteString -> (ByteString, ByteString)) +decodeEnvPairStatic = staticLabel "$decodeEnvPair" + +-- | Closure application +closureApply :: forall a b . + Closure (a -> b) -> Closure a -> Closure b +closureApply (Closure fdec fenv) (Closure xdec xenv) = + closure decoder (encode (fenv, xenv)) + where + decoder :: Static (ByteString -> b) + decoder = appStatic + `staticCompose` + (fdec `staticSplit` xdec) + `staticCompose` + decodeEnvPairStatic + +-- | Closure composition +closureCompose :: Closure (b -> c) -> Closure (a -> b) -> Closure (a -> c) +closureCompose g f = composeStatic `closureApplyStatic` g `closureApply` f + +-- | Closure version of ('Arrow.***') +closureSplit :: Closure (a -> b) -> Closure (a' -> b') -> Closure ((a, a') -> (b, b')) +closureSplit f g = splitStatic `closureApplyStatic` f `closureApply` g diff --git a/packages/network-transport-inmemory/ChangeLog b/packages/network-transport-inmemory/ChangeLog new file mode 100644 index 00000000..614282e4 --- /dev/null +++ b/packages/network-transport-inmemory/ChangeLog @@ -0,0 +1,14 @@ +0.5.4 +* Bump bounds in test suite. +0.5.3 +* Bump bytestring bound to build with ghc-9.8. +0.5.2 +* Introduce internal module. +* Fixes dependency bounds. +0.5.1 +* Fixed bug in cleanup procedure. +0.5 +* Complete reimplementation based on STM primitives. +* Rename Network.Transport.Chan to Network.Transport.InMemory. +* Disable multicast support until it is properly implemented. +* Expose internals. diff --git a/packages/network-transport-inmemory/LICENSE b/packages/network-transport-inmemory/LICENSE new file mode 100644 index 00000000..f3459e44 --- /dev/null +++ b/packages/network-transport-inmemory/LICENSE @@ -0,0 +1,31 @@ +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. + diff --git a/packages/network-transport-inmemory/network-transport-inmemory.cabal b/packages/network-transport-inmemory/network-transport-inmemory.cabal new file mode 100644 index 00000000..a29ad24b --- /dev/null +++ b/packages/network-transport-inmemory/network-transport-inmemory.cabal @@ -0,0 +1,79 @@ +cabal-version: 3.0 +Name: network-transport-inmemory +Version: 0.5.40 +Build-Type: Simple +License: BSD-3-Clause +License-file: LICENSE +Copyright: Well-Typed LLP, Tweag I/O Limited +Author: Duncan Coutts, Nicolas Wu, Edsko de Vries, Alexander Vershilov +maintainer: The Distributed Haskell team +Stability: experimental +Homepage: http://haskell-distributed.github.com +Bug-Reports: https://github.com/haskell-distributed/network-transport-inmemory/issues +Synopsis: In-memory instantiation of Network.Transport +Description: This is a transport implementation that could be used for local + communication in the same address space (i.e. one process). + . + It could be used either for testing purposes or for local + communication that require the network-transport semantics. + . + NB: network-tranpsport-inmemory does not support cross-transport + communication. All endpoints that want to comminicate should be + created using the same transport. + +tested-with: GHC==8.10.7 GHC==9.0.2 GHC==9.2.8 GHC==9.4.5 GHC==9.6.4 GHC==9.8.2 GHC==9.10.1 +Category: Network +extra-source-files: ChangeLog + +Source-Repository head + Type: git + Location: https://github.com/haskell-distributed/network-transport-inmemory + +common warnings + ghc-options: -Wall + -Wcompat + -Widentities + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wredundant-constraints + -fhide-source-paths + -Wpartial-fields + +Library + import: warnings + Build-Depends: base >= 4.14 && < 5, + network-transport >= 0.4.0.0 && < 0.7, + data-accessor >= 0.2 && < 0.3, + bytestring >= 0.10 && < 0.13, + containers >= 0.6 && < 0.8, + stm >= 2.0 && < 3.0 + Exposed-modules: Network.Transport.InMemory + Network.Transport.InMemory.Internal + Network.Transport.InMemory.Debug + default-language: Haskell2010 + HS-Source-Dirs: src + +Test-Suite TestMulticastInMemory + import: warnings + Type: exitcode-stdio-1.0 + Build-Depends: base >= 4.14 && < 5, + network-transport-inmemory, + network-transport, + network-transport-tests >= 0.1 && < 0.4 + Main-Is: TestMulticastInMemory.hs + default-language: Haskell2010 + ghc-options: -fno-warn-unused-do-bind + HS-Source-Dirs: tests + Buildable: False + +Test-Suite TestInMemory + import: warnings + Type: exitcode-stdio-1.0 + Build-Depends: base >= 4.14 && < 5, + network-transport-inmemory, + network-transport-tests >= 0.1 && < 0.4, + network-transport + Main-Is: TestInMemory.hs + default-language: Haskell2010 + ghc-options: -fno-warn-unused-do-bind + HS-Source-Dirs: tests diff --git a/packages/network-transport-inmemory/src/Network/Transport/InMemory.hs b/packages/network-transport-inmemory/src/Network/Transport/InMemory.hs new file mode 100644 index 00000000..51d5232c --- /dev/null +++ b/packages/network-transport-inmemory/src/Network/Transport/InMemory.hs @@ -0,0 +1,20 @@ +-- | In-memory implementation of the Transport API. +module Network.Transport.InMemory + ( createTransport + , createTransportExposeInternals + -- * For testing purposes + , TransportInternals(..) + , breakConnection + ) where + +import Network.Transport +import Network.Transport.InMemory.Internal +import Network.Transport.InMemory.Debug + +-- | Create a new Transport. +-- +-- Only a single transport should be created per Haskell process +-- (threads can, and should, create their own endpoints though). +createTransport :: IO Transport +createTransport = fmap fst createTransportExposeInternals + diff --git a/packages/network-transport-inmemory/src/Network/Transport/InMemory/Debug.hs b/packages/network-transport-inmemory/src/Network/Transport/InMemory/Debug.hs new file mode 100644 index 00000000..2371d97a --- /dev/null +++ b/packages/network-transport-inmemory/src/Network/Transport/InMemory/Debug.hs @@ -0,0 +1,24 @@ +-- | +-- Module: Network.Transport.InMemory.Debug +-- +-- Miscelanteous functions for debug purposes. +module Network.Transport.InMemory.Debug + ( breakConnection + ) where + +import Control.Concurrent.STM +import Network.Transport +import Network.Transport.InMemory.Internal + +-- | Function that simulate failing connection between two endpoints, +-- after calling this function both endpoints will receive ConnectionEventLost +-- message, and all @LocalConnectionValid@ connections will +-- be put into @LocalConnectionFailed@ state. +breakConnection :: TransportInternals + -> EndPointAddress -- ^ @From@ connection + -> EndPointAddress -- ^ @To@ connection + -> String -- ^ Error message + -> IO () +breakConnection (TransportInternals state) from to message = + atomically $ apiBreakConnection state from to message + diff --git a/packages/network-transport-inmemory/src/Network/Transport/InMemory/Internal.hs b/packages/network-transport-inmemory/src/Network/Transport/InMemory/Internal.hs new file mode 100644 index 00000000..6ba184a6 --- /dev/null +++ b/packages/network-transport-inmemory/src/Network/Transport/InMemory/Internal.hs @@ -0,0 +1,445 @@ +{-# LANGUAGE RecursiveDo #-} +{-# OPTIONS_GHC -fno-warn-deprecations #-} +-- | +-- Module: Network.Transport.InMemory.Internal +-- +-- Internal part of the implementation. This module is for internal use +-- or advanced debuging. There are no guarantees about stability of this +-- module. +module Network.Transport.InMemory.Internal + ( createTransportExposeInternals + -- * Internal structures + , TransportInternals(..) + , TransportState(..) + , ValidTransportState(..) + , LocalEndPoint(..) + , LocalEndPointState(..) + , ValidLocalEndPointState(..) + , LocalConnection(..) + , LocalConnectionState(..) + -- * Low level functionality + , apiNewEndPoint + , apiCloseEndPoint + , apiBreakConnection + , apiConnect + , apiSend + , apiClose + ) where + +import Network.Transport +import Network.Transport.Internal ( mapIOException ) +import Control.Category ((>>>)) +import Control.Concurrent.STM +import Control.Exception (handle, throw) +import Data.Map (Map) +import Data.Maybe (fromJust) +import Data.Monoid +import Data.Foldable +import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BSC (pack) +import Data.Accessor (Accessor, accessor, (^.), (^=), (^:)) +import qualified Data.Accessor.Container as DAC (mapMaybe) +import Data.Typeable (Typeable) +import Prelude hiding (foldr) + +data TransportState + = TransportValid {-# UNPACK #-} !ValidTransportState + | TransportClosed + +data ValidTransportState = ValidTransportState + { _localEndPoints :: !(Map EndPointAddress LocalEndPoint) + , _nextLocalEndPointId :: !Int + } + +data LocalEndPoint = LocalEndPoint + { localEndPointAddress :: !EndPointAddress + , localEndPointChannel :: !(TChan Event) + , localEndPointState :: !(TVar LocalEndPointState) + } + +data LocalEndPointState + = LocalEndPointValid {-# UNPACK #-} !ValidLocalEndPointState + | LocalEndPointClosed + +data ValidLocalEndPointState = ValidLocalEndPointState + { _nextConnectionId :: !ConnectionId + , _connections :: !(Map (EndPointAddress,ConnectionId) LocalConnection) + , _multigroups :: Map MulticastAddress (TVar (Set EndPointAddress)) + } + +data LocalConnection = LocalConnection + { localConnectionId :: !ConnectionId + , localConnectionLocalAddress :: !EndPointAddress + , localConnectionRemoteAddress :: !EndPointAddress + , localConnectionState :: !(TVar LocalConnectionState) + } + +data LocalConnectionState + = LocalConnectionValid + | LocalConnectionClosed + | LocalConnectionFailed + +newtype TransportInternals = TransportInternals (TVar TransportState) + +-- | Create a new Transport exposing internal state. +-- +-- Useful for testing and/or debugging purposes. +-- Should not be used in production. No guarantee as to the stability of the internals API. +createTransportExposeInternals :: IO (Transport, TransportInternals) +createTransportExposeInternals = do + state <- newTVarIO $ TransportValid $ ValidTransportState + { _localEndPoints = Map.empty + , _nextLocalEndPointId = 0 + } + return (Transport + { newEndPoint = apiNewEndPoint state + , closeTransport = do + -- transactions are splitted into smaller ones intentionally + old <- atomically $ swapTVar state TransportClosed + case old of + TransportClosed -> return () + TransportValid tvst -> do + forM_ (tvst ^. localEndPoints) $ \l -> do + cons <- atomically $ whenValidLocalEndPointState l $ \lvst -> do + writeTChan (localEndPointChannel l) EndPointClosed + writeTVar (localEndPointState l) LocalEndPointClosed + return (lvst ^. connections) + forM_ cons $ \con -> atomically $ + writeTVar (localConnectionState con) LocalConnectionClosed + }, TransportInternals state) + + +-- | Create a new end point. +apiNewEndPoint :: TVar TransportState + -> IO (Either (TransportError NewEndPointErrorCode) EndPoint) +apiNewEndPoint state = handle (return . Left) $ atomically $ do + chan <- newTChan + (lep,addr) <- withValidTransportState state NewEndPointFailed $ \vst -> do + lepState <- newTVar $ LocalEndPointValid $ ValidLocalEndPointState + { _nextConnectionId = 1 + , _connections = Map.empty + , _multigroups = Map.empty + } + let r = nextLocalEndPointId ^: (+ 1) $ vst + addr = EndPointAddress . BSC.pack . show $ r ^. nextLocalEndPointId + lep = LocalEndPoint + { localEndPointAddress = addr + , localEndPointChannel = chan + , localEndPointState = lepState + } + writeTVar state (TransportValid $ localEndPointAt addr ^= Just lep $ r) + return (lep, addr) + return $ Right $ EndPoint + { receive = atomically $ do + result <- tryReadTChan chan + case result of + Nothing -> do st <- readTVar (localEndPointState lep) + case st of + LocalEndPointClosed -> + throwSTM (userError "Channel is closed.") + LocalEndPointValid{} -> retry + Just x -> return x + , address = addr + , connect = apiConnect addr state + , closeEndPoint = apiCloseEndPoint state addr + , newMulticastGroup = return $ Left $ newMulticastGroupError + , resolveMulticastGroup = return . Left . const resolveMulticastGroupError + } + where + -- see [Multicast] section + newMulticastGroupError = + TransportError NewMulticastGroupUnsupported "Multicast not supported" + resolveMulticastGroupError = + TransportError ResolveMulticastGroupUnsupported "Multicast not supported" + +apiCloseEndPoint :: TVar TransportState -> EndPointAddress -> IO () +apiCloseEndPoint state addr = atomically $ whenValidTransportState state $ \vst -> + forM_ (vst ^. localEndPointAt addr) $ \lep -> do + old <- swapTVar (localEndPointState lep) LocalEndPointClosed + case old of + LocalEndPointClosed -> return () + LocalEndPointValid lepvst -> do + forM_ (Map.elems (lepvst ^. connections)) $ \lconn -> do + st <- swapTVar (localConnectionState lconn) LocalConnectionClosed + case st of + LocalConnectionClosed -> return () + LocalConnectionFailed -> return () + _ -> forM_ (vst ^. localEndPointAt (localConnectionRemoteAddress lconn)) $ \thep -> + whenValidLocalEndPointState thep $ \_ -> do + writeTChan (localEndPointChannel thep) + (ConnectionClosed (localConnectionId lconn)) + writeTChan (localEndPointChannel lep) EndPointClosed + writeTVar (localEndPointState lep) LocalEndPointClosed + writeTVar state (TransportValid $ (localEndPoints ^: Map.delete addr) vst) + +-- | Tear down functions that should be called in case if conncetion fails. +apiBreakConnection :: TVar TransportState + -> EndPointAddress + -> EndPointAddress + -> String + -> STM () +apiBreakConnection state us them msg + | us == them = return () + | otherwise = whenValidTransportState state $ \vst -> do + breakOne vst us them >> breakOne vst them us + where + breakOne vst a b = do + forM_ (vst ^. localEndPointAt a) $ \lep -> + whenValidLocalEndPointState lep $ \lepvst -> do + let (cl, other) = Map.partitionWithKey (\(addr,_) _ -> addr == b) + (lepvst ^.connections) + forM_ cl $ \c -> modifyTVar (localConnectionState c) + (\x -> case x of + LocalConnectionValid -> LocalConnectionFailed + _ -> x) + writeTChan (localEndPointChannel lep) + (ErrorEvent (TransportError (EventConnectionLost b) msg)) + writeTVar (localEndPointState lep) + (LocalEndPointValid $ (connections ^= other) lepvst) + + +-- | Create a new connection +apiConnect :: EndPointAddress + -> TVar TransportState + -> EndPointAddress + -> Reliability + -> ConnectHints + -> IO (Either (TransportError ConnectErrorCode) Connection) +apiConnect ourAddress state theirAddress _reliability _hints = do + handle (return . Left) $ fmap Right $ atomically $ do + (chan, lconn) <- do + withValidTransportState state ConnectFailed $ \vst -> do + ourlep <- case vst ^. localEndPointAt ourAddress of + Nothing -> + throwSTM $ TransportError ConnectFailed "Endpoint closed" + Just x -> return x + theirlep <- case vst ^. localEndPointAt theirAddress of + Nothing -> + throwSTM $ TransportError ConnectNotFound "Endpoint not found" + Just x -> return x + conid <- withValidLocalEndPointState theirlep ConnectFailed $ \lepvst -> do + let r = nextConnectionId ^: (+ 1) $ lepvst + writeTVar (localEndPointState theirlep) (LocalEndPointValid r) + return (r ^. nextConnectionId) + withValidLocalEndPointState ourlep ConnectFailed $ \lepvst -> do + lconnState <- newTVar LocalConnectionValid + let lconn = LocalConnection + { localConnectionId = conid + , localConnectionLocalAddress = ourAddress + , localConnectionRemoteAddress = theirAddress + , localConnectionState = lconnState + } + writeTVar (localEndPointState ourlep) + (LocalEndPointValid $ + connectionAt (theirAddress, conid) ^= lconn $ lepvst) + return (localEndPointChannel theirlep, lconn) + writeTChan chan $ + ConnectionOpened (localConnectionId lconn) ReliableOrdered ourAddress + return $ Connection + { send = apiSend chan state lconn + , close = apiClose chan state lconn + } + +-- | Send a message over a connection +apiSend :: TChan Event + -> TVar TransportState + -> LocalConnection + -> [ByteString] + -> IO (Either (TransportError SendErrorCode) ()) +apiSend chan state lconn msg = handle handleFailure $ mapIOException sendFailed $ + atomically $ do + connst <- readTVar (localConnectionState lconn) + case connst of + LocalConnectionValid -> do + foldr seq () msg `seq` + writeTChan chan (Received (localConnectionId lconn) msg) + return $ Right () + LocalConnectionClosed -> do + -- If the local connection was closed, check why. + withValidTransportState state SendFailed $ \vst -> do + let addr = localConnectionLocalAddress lconn + mblep = vst ^. localEndPointAt addr + case mblep of + Nothing -> throwSTM $ TransportError SendFailed "Endpoint closed" + Just lep -> do + lepst <- readTVar (localEndPointState lep) + case lepst of + LocalEndPointValid _ -> do + return $ Left $ TransportError SendClosed "Connection closed" + LocalEndPointClosed -> do + throwSTM $ TransportError SendFailed "Endpoint closed" + LocalConnectionFailed -> return $ + Left $ TransportError SendFailed "Endpoint closed" + where + sendFailed = TransportError SendFailed . show + handleFailure ex@(TransportError SendFailed reason) = atomically $ do + apiBreakConnection state (localConnectionLocalAddress lconn) + (localConnectionRemoteAddress lconn) + reason + return (Left ex) + handleFailure ex = return (Left ex) + +-- | Close a connection +apiClose :: TChan Event + -> TVar TransportState + -> LocalConnection + -> IO () +apiClose chan state lconn = do + atomically $ do -- XXX: whenValidConnectionState + connst <- readTVar (localConnectionState lconn) + case connst of + LocalConnectionValid -> do + writeTChan chan $ ConnectionClosed (localConnectionId lconn) + writeTVar (localConnectionState lconn) LocalConnectionClosed + whenValidTransportState state $ \vst -> do + let mblep = vst ^. localEndPointAt (localConnectionLocalAddress lconn) + theirAddress = localConnectionRemoteAddress lconn + forM_ mblep $ \lep -> + whenValidLocalEndPointState lep $ + writeTVar (localEndPointState lep) + . LocalEndPointValid + . (connections ^: Map.delete (theirAddress, localConnectionId lconn)) + _ -> return () + +-- [Multicast] +-- Currently multicast implementation doesn't pass it's tests, so it +-- disabled. Here we have old code that could be improved, see GitHub ISSUE 5 +-- https://github.com/haskell-distributed/network-transport-inmemory/issues/5 + +-- | Construct a multicast group +-- +-- When the group is deleted some endpoints may still receive messages, but +-- subsequent calls to resolveMulticastGroup will fail. This mimicks the fact +-- that some multicast messages may still be in transit when the group is +-- deleted. +createMulticastGroup :: TVar TransportState + -> EndPointAddress + -> MulticastAddress + -> TVar (Set EndPointAddress) + -> MulticastGroup +createMulticastGroup state ourAddress groupAddress group = MulticastGroup + { multicastAddress = groupAddress + , deleteMulticastGroup = atomically $ + whenValidTransportState state $ \vst -> do + -- XXX best we can do given current broken API, which needs fixing. + let lep = fromJust $ vst ^. localEndPointAt ourAddress + modifyTVar' (localEndPointState lep) $ \lepst -> case lepst of + LocalEndPointValid lepvst -> + LocalEndPointValid $ multigroups ^: Map.delete groupAddress $ lepvst + LocalEndPointClosed -> + LocalEndPointClosed + , maxMsgSize = Nothing + , multicastSend = \payload -> atomically $ + withValidTransportState state SendFailed $ \vst -> do + es <- readTVar group + forM_ (Set.elems es) $ \ep -> do + let ch = localEndPointChannel $ fromJust $ vst ^. localEndPointAt ep + writeTChan ch (ReceivedMulticast groupAddress payload) + , multicastSubscribe = atomically $ modifyTVar' group $ Set.insert ourAddress + , multicastUnsubscribe = atomically $ modifyTVar' group $ Set.delete ourAddress + , multicastClose = return () + } + +-- | Create a new multicast group +_apiNewMulticastGroup :: TVar TransportState + -> EndPointAddress + -> IO (Either (TransportError NewMulticastGroupErrorCode) MulticastGroup) +_apiNewMulticastGroup state ourAddress = handle (return . Left) $ do + group <- newTVarIO Set.empty + groupAddr <- atomically $ + withValidTransportState state NewMulticastGroupFailed $ \vst -> do + lep <- maybe (throwSTM $ TransportError NewMulticastGroupFailed "Endpoint closed") + return + (vst ^. localEndPointAt ourAddress) + withValidLocalEndPointState lep NewMulticastGroupFailed $ \lepvst -> do + let addr = MulticastAddress . BSC.pack . show . Map.size $ lepvst ^. multigroups + writeTVar (localEndPointState lep) (LocalEndPointValid $ multigroupAt addr ^= group $ lepvst) + return addr + return . Right $ createMulticastGroup state ourAddress groupAddr group + +-- | Resolve a multicast group +_apiResolveMulticastGroup :: TVar TransportState + -> EndPointAddress + -> MulticastAddress + -> IO (Either (TransportError ResolveMulticastGroupErrorCode) MulticastGroup) +_apiResolveMulticastGroup state ourAddress groupAddress = handle (return . Left) $ atomically $ + withValidTransportState state ResolveMulticastGroupFailed $ \vst -> do + lep <- maybe (throwSTM $ TransportError ResolveMulticastGroupFailed "Endpoint closed") + return + (vst ^. localEndPointAt ourAddress) + withValidLocalEndPointState lep ResolveMulticastGroupFailed $ \lepvst -> do + let group = lepvst ^. (multigroups >>> DAC.mapMaybe groupAddress) + case group of + Nothing -> + return . Left $ + TransportError ResolveMulticastGroupNotFound + ("Group " ++ show groupAddress ++ " not found") + Just mvar -> + return . Right $ createMulticastGroup state ourAddress groupAddress mvar + +-------------------------------------------------------------------------------- +-- Lens definitions -- +-------------------------------------------------------------------------------- + +nextLocalEndPointId :: Accessor ValidTransportState Int +nextLocalEndPointId = accessor _nextLocalEndPointId (\eid st -> st{ _nextLocalEndPointId = eid} ) + +localEndPoints :: Accessor ValidTransportState (Map EndPointAddress LocalEndPoint) +localEndPoints = accessor _localEndPoints (\leps st -> st { _localEndPoints = leps }) + +nextConnectionId :: Accessor ValidLocalEndPointState ConnectionId +nextConnectionId = accessor _nextConnectionId (\cid st -> st { _nextConnectionId = cid }) + +connections :: Accessor ValidLocalEndPointState (Map (EndPointAddress,ConnectionId) LocalConnection) +connections = accessor _connections (\conns st -> st { _connections = conns }) + +multigroups :: Accessor ValidLocalEndPointState (Map MulticastAddress (TVar (Set EndPointAddress))) +multigroups = accessor _multigroups (\gs st -> st { _multigroups = gs }) + +at :: Ord k => k -> String -> Accessor (Map k v) v +at k err = accessor (Map.findWithDefault (error err) k) (Map.insert k) + +localEndPointAt :: EndPointAddress -> Accessor ValidTransportState (Maybe LocalEndPoint) +localEndPointAt addr = localEndPoints >>> DAC.mapMaybe addr + +connectionAt :: (EndPointAddress, ConnectionId) -> Accessor ValidLocalEndPointState LocalConnection +connectionAt addr = connections >>> at addr "Invalid connection" + +multigroupAt :: MulticastAddress -> Accessor ValidLocalEndPointState (TVar (Set EndPointAddress)) +multigroupAt addr = multigroups >>> at addr "Invalid multigroup" + +--------------------------------------------------------------------------------- +-- Helpers +--------------------------------------------------------------------------------- + +-- | LocalEndPoint state deconstructor. +overValidLocalEndPointState :: LocalEndPoint -> STM a -> (ValidLocalEndPointState -> STM a) -> STM a +overValidLocalEndPointState lep fallback action = do + lepst <- readTVar (localEndPointState lep) + case lepst of + LocalEndPointValid lepvst -> action lepvst + _ -> fallback + +-- | Specialized deconstructor that throws TransportError in case of Closed state +withValidLocalEndPointState :: (Typeable e, Show e) => LocalEndPoint -> e -> (ValidLocalEndPointState -> STM a) -> STM a +withValidLocalEndPointState lep ex = overValidLocalEndPointState lep (throw $ TransportError ex "EndPoint closed") + +-- | Specialized deconstructor that do nothing in case of failure +whenValidLocalEndPointState :: Monoid m => LocalEndPoint -> (ValidLocalEndPointState -> STM m) -> STM m +whenValidLocalEndPointState lep = overValidLocalEndPointState lep (return mempty) + +overValidTransportState :: TVar TransportState -> STM a -> (ValidTransportState -> STM a) -> STM a +overValidTransportState ts fallback action = do + tsst <- readTVar ts + case tsst of + TransportValid tsvst -> action tsvst + _ -> fallback + +withValidTransportState :: (Typeable e, Show e) => TVar TransportState -> e -> (ValidTransportState -> STM a) -> STM a +withValidTransportState ts ex = overValidTransportState ts (throw $ TransportError ex "Transport closed") + +whenValidTransportState :: Monoid m => TVar TransportState -> (ValidTransportState -> STM m) -> STM m +whenValidTransportState ts = overValidTransportState ts (return mempty) diff --git a/packages/network-transport-inmemory/tests/TestInMemory.hs b/packages/network-transport-inmemory/tests/TestInMemory.hs new file mode 100644 index 00000000..ad973dec --- /dev/null +++ b/packages/network-transport-inmemory/tests/TestInMemory.hs @@ -0,0 +1,38 @@ +module Main where + +import Network.Transport.Tests +import Network.Transport.Tests.Auxiliary (runTests) +import Network.Transport.InMemory +import Network.Transport +import Control.Applicative ((<$>)) + +main :: IO () +main = do + Right transport <- newTransport + killTransport <- newTransport + runTests + [ ("PingPong", testPingPong transport numPings) + , ("EndPoints", testEndPoints transport numPings) + , ("Connections", testConnections transport numPings) + , ("CloseOneConnection", testCloseOneConnection transport numPings) + , ("CloseOneDirection", testCloseOneDirection transport numPings) + , ("CloseReopen", testCloseReopen transport numPings) + , ("ParallelConnects", testParallelConnects transport numPings) + , ("SendAfterClose", testSendAfterClose transport 100) + , ("Crossing", testCrossing transport 10) + , ("CloseTwice", testCloseTwice transport 100) + , ("ConnectToSelf", testConnectToSelf transport numPings) + , ("ConnectToSelfTwice", testConnectToSelfTwice transport numPings) + , ("CloseSelf", testCloseSelf newTransport) + , ("CloseEndPoint", testCloseEndPoint transport numPings) + -- XXX: require transport communication + -- ("CloseTransport", testCloseTransport newTransport) + , ("ConnectClosedEndPoint", testConnectClosedEndPoint transport) + , ("ExceptionOnReceive", testExceptionOnReceive newTransport) + , ("SendException", testSendException newTransport) + , ("Kill", testKill (return killTransport) 1000) + ] + closeTransport transport + where + numPings = 10000 :: Int + newTransport = Right <$> createTransport diff --git a/packages/network-transport-inmemory/tests/TestMulticastInMemory.hs b/packages/network-transport-inmemory/tests/TestMulticastInMemory.hs new file mode 100644 index 00000000..9278c865 --- /dev/null +++ b/packages/network-transport-inmemory/tests/TestMulticastInMemory.hs @@ -0,0 +1,7 @@ +module Main where + +import Network.Transport.Tests.Multicast +import Network.Transport.InMemory (createTransport) + +main :: IO () +main = createTransport >>= testMulticast diff --git a/packages/network-transport-tcp/ChangeLog b/packages/network-transport-tcp/ChangeLog new file mode 100644 index 00000000..640fa0c5 --- /dev/null +++ b/packages/network-transport-tcp/ChangeLog @@ -0,0 +1,103 @@ +2024-07-09 Laurent P. René de Cotret 0.8.4 + +* Set TCP_NODELAY by default. The documentation erroneously reported it as the default. (#66) + +2023-03-26 David Simmons-Duffin 0.8.3 + +* Disable a flaky test + +2023-03-25 David Simmons-Duffin 0.8.2 + +* Bump bytestring version to build with GHC 9.8. + +2022-10-12 FacundoDominguez 0.8.1 + +* Fix imports for ghc 9 (#93). + +2020-10-09 FacundoDominguez 0.8.0 + +* Move to network 3. + +2019-12-31 FacundoDominguez 0.7.0 + +* Added support for unaddressable endpoints. (#61) + +2019-12-31 FacundoDominguez 0.6.1 + +* Relax dependency bounds to build with ghc-8.6.5 +* apiSend RELY violation is removed for closed remote endpoints (#70) +* The server no longer needs crash if accept throws an exception. +* Check peer-reported host against socket host (#54) +* Fix possible endless waiting on the 'crossed' MVar (#74) +* Fix possible msg corruption on a busy network (#85) + +2017-08-21 FacundoDominguez 0.6.0 + +* Implemented protocol versioning (#55) +* Extend interface so queue policies and lengths can be configured. +* Test improvements +* Fix races when an EndPoint is closed or failed (#60) +* Fix timeout socket connections (#53) +* Use equality rather than ordering in socket close (#56) +* apiCloseEndPoint blocks until no longer reciving +* Shutdown sockets when closing endpoints +* Allow computing the external address from the chosen bind port (#50) +* Discard remote endpoints when they close or fail (#43) + +2016-02-17 FacundoDominguez 0.5.0 + +* Add TCP_KEEPALIVE support for sockets. +* Run nearly all tests on non hardcoded ports. +* Remove obsolete top-level Makefile. +* Yield an error when tcpUserTimeout is set in unsupported systems. +* Fix for NTTCP-10. Have apiConnect respect timeouts. +* Make schedule - runScheduled pair exception safe. +* Allow to specify a default timeout for all connect calls. +* Allow to set TCP_USER_TIMEOUT on tcp connections. +* Implement configuration parameter to set TCP_NODELAY. +* Fix for NTTCP-9 / #23. Handle network failures when connection requests cross. + +2015-06-15 FacundoDominguez 0.4.2 + +* Update dependencies. +* Fixes in test-suite. +* Bug fixes DP-109, NTTCP-11. + +2014-12-09 Tim Watson 0.4.1 + +* Update dependencies + +2014-05-30 Tim Watson 0.4.0 + +* Update dependencies + +2012-10-19 Edsko de Vries 0.3.1 + +* Bugfix. Reconnecting between endpoints did not work under certain +circumstances. + +2012-10-03 Edsko de Vries 0.3.0 + +* Implement new disconnection semantics +* Make 'connect' asynchronous (sender allocated connection IDs) +* Fix distributed deadlock +* Optimize treatment of crossed connection requests +* Relax upper bound on network +* Fix memory leaks + +2012-08-20 Edsko de Vries 0.2.0.3 + +* Allow for colons in hostnames (for IPv6) + +2012-07-16 Edsko de Vries 0.2.0.2 + +* Base 4.6 compatibility +* Relax package contraints on bytestring and containers + +2012-07-12 Edsko de Vries 0.2.0.1 + +* Fix bug in recvExact + +2012-07-07 Edsko de Vries 0.2.0 + +* Initial release. diff --git a/packages/network-transport-tcp/LICENSE b/packages/network-transport-tcp/LICENSE new file mode 100644 index 00000000..7e437eb7 --- /dev/null +++ b/packages/network-transport-tcp/LICENSE @@ -0,0 +1,32 @@ +Copyright Well-Typed LLP, 2011-2012 +Copyright Tweag I/O Limited, 2015 + +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. + diff --git a/packages/network-transport-tcp/benchmarks/Headers.gnuplot b/packages/network-transport-tcp/benchmarks/Headers.gnuplot new file mode 100644 index 00000000..131a3569 --- /dev/null +++ b/packages/network-transport-tcp/benchmarks/Headers.gnuplot @@ -0,0 +1,16 @@ +set title "Roundtrip (us)" +set yrange [0:150] +plot "JustPingHaskellNT.data" smooth bezier with lines title "JustPingHaskell (NOT -threaded)", \ + "JustPingHaskell.data" smooth bezier with lines title "JustPingHaskell", \ + "JustPingWithHeader.data" smooth bezier with lines title "JustPingWithHeader", \ + "JustPingOneRecv.data" smooth bezier with lines title "JustPingOneRecv", \ + "JustPingCacheHeader.data" smooth bezier with lines title "JustPingCacheHeader", \ + "JustPingC.data" smooth bezier with lines title "JustPingC" +set terminal postscript color +set output "Headers.ps" +plot "JustPingHaskellNT.data" smooth bezier with lines title "JustPingHaskell (NOT -threaded)", \ + "JustPingHaskell.data" smooth bezier with lines title "JustPingHaskell", \ + "JustPingWithHeader.data" smooth bezier with lines title "JustPingWithHeader", \ + "JustPingOneRecv.data" smooth bezier with lines title "JustPingOneRecv", \ + "JustPingCacheHeader.data" smooth bezier with lines title "JustPingCacheHeader", \ + "JustPingC.data" smooth bezier with lines title "JustPingC" diff --git a/packages/network-transport-tcp/benchmarks/Indirection.gnuplot b/packages/network-transport-tcp/benchmarks/Indirection.gnuplot new file mode 100644 index 00000000..e7808707 --- /dev/null +++ b/packages/network-transport-tcp/benchmarks/Indirection.gnuplot @@ -0,0 +1,16 @@ +set title "Roundtrip (us)" +set yrange [0:150] +plot "JustPingWithHeader.data" smooth bezier with lines title "JustPingWithHeader", \ + "JustPingThroughChan.data" smooth bezier with lines title "JustPingThroughChan", \ + "JustPingThroughMVar.data" smooth bezier with lines title "JustPingThroughMVar", \ + "JustPingTwoSocketPairs.data" smooth bezier with lines title "JustPingTwoSocketPairs", \ + "JustPingTwoSocketPairsND.data" smooth bezier with lines title "JustPingTwoSocketPairs (--NoDelay)", \ + "JustPingTransport.data" smooth bezier with lines title "JustPingTransport" +set terminal postscript color +set output "Indirection.ps" +plot "JustPingWithHeader.data" smooth bezier with lines title "JustPingWithHeader", \ + "JustPingThroughChan.data" smooth bezier with lines title "JustPingThroughChan", \ + "JustPingThroughMVar.data" smooth bezier with lines title "JustPingThroughMVar", \ + "JustPingTwoSocketPairs.data" smooth bezier with lines title "JustPingTwoSocketPairs", \ + "JustPingTwoSocketPairsND.data" smooth bezier with lines title "JustPingTwoSocketPairs (--NoDelay)", \ + "JustPingTransport.data" smooth bezier with lines title "JustPingTransport" diff --git a/packages/network-transport-tcp/benchmarks/JustPingC.c b/packages/network-transport-tcp/benchmarks/JustPingC.c new file mode 100644 index 00000000..8f6416e9 --- /dev/null +++ b/packages/network-transport-tcp/benchmarks/JustPingC.c @@ -0,0 +1,150 @@ +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +// Note: this is not consistent across CPUs (and hence across threads on multicore machines) +double timestamp() { + struct timeval tp; + gettimeofday(&tp, NULL); + return ((double) tp.tv_sec) * 1e6 + (double) tp.tv_usec; +} + +int server() { + printf("starting server\n"); + + struct addrinfo hints, *res; + int error, server_socket; + + memset(&hints, 0, sizeof(hints)); + hints.ai_family = PF_INET; + hints.ai_socktype = SOCK_STREAM; + hints.ai_flags = AI_PASSIVE; + + error = getaddrinfo(NULL, "8080", &hints, &res); + if(error) { + printf("server error: %s\n", gai_strerror(error)); + return -1; + } + + server_socket = socket(res->ai_family, res->ai_socktype, res->ai_protocol); + if(server_socket < 0) { + printf("server error: could not create socket\n"); + return -1; + } + + int yes = 1; + if(setsockopt(server_socket, SOL_SOCKET, SO_REUSEADDR, &yes, sizeof(int)) < 0) { + printf("server error: could not set socket options\n"); + return -1; + } + + if(bind(server_socket, res->ai_addr, res->ai_addrlen) < 0) { + printf("server error: could not bind to socket\n"); + return -1; + } + + listen(server_socket, 5); + + int client_socket; + struct sockaddr_storage client_addr; + socklen_t addr_size; + client_socket = accept(server_socket, (struct sockaddr *)&client_addr, &addr_size); + + for(;;) { + char* buf = malloc(8); + ssize_t read = recv(client_socket, buf, 8, 0); + if(read == 0) { + free(buf); + break; + } + // printf("server received '%s'\n", buf); + send(client_socket, buf, 8, 0); + free(buf); + } + + freeaddrinfo(res); + return 0; +} + +int client(int pings) { + printf("starting client\n"); + + struct addrinfo hints, *res; + int error, client_socket, i; + + memset(&hints, 0, sizeof(hints)); + hints.ai_family = PF_INET; + hints.ai_socktype = SOCK_STREAM; + + error = getaddrinfo("127.0.0.1", "8080", &hints, &res); + if(error) { + printf("client error: %s\n", gai_strerror(error)); + return -1; + } + + client_socket = socket(res->ai_family, res->ai_socktype, res->ai_protocol); + if(client_socket < 0) { + printf("client error: could not create socket\n"); + return -1; + } + + if(connect(client_socket, res->ai_addr, res->ai_addrlen) < 0) { + printf("client error: could not connect: %s\n", strerror(errno)); + return -1; + } + + for(i = 0; i < pings; i++) { + double timestamp_before = timestamp(); + + send(client_socket, "ping123", 8, 0); + + char *buf = malloc(8); + ssize_t read = recv(client_socket, buf, 8, 0); + + if(read == 0) { + printf("server exited prematurely\n"); + free(buf); + break; + } + + // printf("client received '%s'\n", buf); + free(buf); + + double timestamp_after = timestamp(); + fprintf(stderr, "%i %lf\n", i, timestamp_after - timestamp_before); + } + + printf("client did %d pings\n", pings); + + freeaddrinfo(res); + return 0; +} + +int usage(int argc, char** argv) { + printf("usage: %s \n", argv[0]); + return -1; +} + +int main(int argc, char** argv) { + if(argc != 2) { + return usage(argc, argv); + } + + if(fork() == 0) { + // TODO: we should wait until we know the server is ready + int pings = 0; + sscanf(argv[1], "%d", &pings); + return client(pings); + } else { + return server(); + } +} diff --git a/packages/network-transport-tcp/benchmarks/JustPingCacheHeader.hs b/packages/network-transport-tcp/benchmarks/JustPingCacheHeader.hs new file mode 100644 index 00000000..b57b5d3a --- /dev/null +++ b/packages/network-transport-tcp/benchmarks/JustPingCacheHeader.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE CPP, BangPatterns #-} + +module Main where + +import Control.Monad + +import Data.Int +import Network.Socket + ( AddrInfoFlag (AI_PASSIVE), HostName, ServiceName, Socket + , SocketType (Stream), SocketOption (ReuseAddr) + , accept, addrAddress, addrFlags, addrFamily, bindSocket, defaultProtocol + , defaultHints + , getAddrInfo, listen, setSocketOption, socket, sClose, withSocketsDo ) +import System.Environment (getArgs, withArgs) +import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime) +import System.IO (withFile, IOMode(..), hPutStrLn, Handle, stderr) +import Control.Concurrent (forkIO) +import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar) +import qualified Network.Socket as N +import Debug.Trace +import Data.ByteString (ByteString) +import Data.ByteString.Char8 (pack, unpack) +import qualified Data.ByteString as BS +import qualified Network.Socket.ByteString as NBS +import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime) +import Data.ByteString.Internal as BSI +import Foreign.Storable (pokeByteOff, peekByteOff) +import Foreign.C (CInt(..)) +import Foreign.ForeignPtr (withForeignPtr) + +foreign import ccall unsafe "htonl" htonl :: CInt -> CInt +foreign import ccall unsafe "ntohl" ntohl :: CInt -> CInt + +main :: IO () +main = do + [pingsStr] <- getArgs + serverReady <- newEmptyMVar + clientDone <- newEmptyMVar + + -- Start the server + forkIO $ do + putStrLn "server: creating TCP connection" + serverAddrs <- getAddrInfo + (Just (defaultHints { addrFlags = [AI_PASSIVE] } )) + Nothing + (Just "8080") + let serverAddr = head serverAddrs + sock <- socket (addrFamily serverAddr) Stream defaultProtocol + setSocketOption sock ReuseAddr 1 + bindSocket sock (addrAddress serverAddr) + + putStrLn "server: awaiting client connection" + putMVar serverReady () + listen sock 1 + (clientSock, clientAddr) <- accept sock + + putStrLn "server: listening for pings" + pong clientSock + + -- Start the client + forkIO $ do + takeMVar serverReady + let pings = read pingsStr + serverAddrs <- getAddrInfo + Nothing + (Just "127.0.0.1") + (Just "8080") + let serverAddr = head serverAddrs + sock <- socket (addrFamily serverAddr) Stream defaultProtocol + + N.connect sock (addrAddress serverAddr) + + ping sock pings + putMVar clientDone () + + -- Wait for the client to finish + takeMVar clientDone + +pingMessage :: ByteString +pingMessage = pack "ping123" + +ping :: Socket -> Int -> IO () +ping sock pings = go pings + where + go :: Int -> IO () + go 0 = do + putStrLn $ "client did " ++ show pings ++ " pings" + go !i = do + before <- getCurrentTime + send sock pingMessage + bs <- recv sock 8 + after <- getCurrentTime + -- putStrLn $ "client received " ++ unpack bs + let latency = (1e6 :: Double) * realToFrac (diffUTCTime after before) + hPutStrLn stderr $ show i ++ " " ++ show latency + go (i - 1) + +pong :: Socket -> IO () +pong sock = do + bs <- recv sock 8 + -- putStrLn $ "server received " ++ unpack bs + when (BS.length bs > 0) $ do + send sock bs + pong sock + +-- | Wrapper around NBS.recv (for profiling) +recv :: Socket -> Int -> IO ByteString +recv sock i = do + (header, payload) <- BS.splitAt 4 `fmap` NBS.recv sock (4 + i) + -- Ignore header + return payload + +-- | Cached header +header :: ByteString +header = pack "fake" + +-- | Wrapper around NBS.send (for profiling) +send :: Socket -> ByteString -> IO () +send sock bs = do + NBS.sendMany sock [header, bs] + +-- | Encode length (manual for now) +encodeLength :: Int32 -> IO ByteString +encodeLength i32 = + BSI.create 4 $ \p -> + pokeByteOff p 0 (htonl (fromIntegral i32)) + +-- | Decode length (manual for now) +decodeLength :: ByteString -> IO Int32 +decodeLength bs = + let (fp, _, _) = BSI.toForeignPtr bs in + withForeignPtr fp $ \p -> do + w32 <- peekByteOff p 0 + return (fromIntegral (ntohl w32)) diff --git a/packages/network-transport-tcp/benchmarks/JustPingHaskell.hs b/packages/network-transport-tcp/benchmarks/JustPingHaskell.hs new file mode 100644 index 00000000..c69fc7d0 --- /dev/null +++ b/packages/network-transport-tcp/benchmarks/JustPingHaskell.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE CPP, BangPatterns #-} + +module Main where + +import Control.Monad + +import Data.Int +import Network.Socket + ( AddrInfoFlag (AI_PASSIVE), HostName, ServiceName, Socket + , SocketType (Stream), SocketOption (ReuseAddr) + , accept, addrAddress, addrFlags, addrFamily, bindSocket, defaultProtocol + , defaultHints + , getAddrInfo, listen, setSocketOption, socket, sClose, withSocketsDo ) +import System.Environment (getArgs, withArgs) +import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime) +import System.IO (withFile, IOMode(..), hPutStrLn, Handle, stderr) +import Control.Concurrent (forkIO) +import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar) +import qualified Network.Socket as N +import Debug.Trace +import Data.ByteString (ByteString) +import Data.ByteString.Char8 (pack, unpack) +import qualified Data.ByteString as BS +import qualified Network.Socket.ByteString as NBS +import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime) + +main :: IO () +main = do + [pingsStr] <- getArgs + serverReady <- newEmptyMVar + clientDone <- newEmptyMVar + + -- Start the server + forkIO $ do + putStrLn "server: creating TCP connection" + serverAddrs <- getAddrInfo + (Just (defaultHints { addrFlags = [AI_PASSIVE] } )) + Nothing + (Just "8080") + let serverAddr = head serverAddrs + sock <- socket (addrFamily serverAddr) Stream defaultProtocol + setSocketOption sock ReuseAddr 1 + bindSocket sock (addrAddress serverAddr) + + putStrLn "server: awaiting client connection" + putMVar serverReady () + listen sock 1 + (clientSock, clientAddr) <- accept sock + + putStrLn "server: listening for pings" + pong clientSock + + -- Start the client + forkIO $ do + takeMVar serverReady + let pings = read pingsStr + serverAddrs <- getAddrInfo + Nothing + (Just "127.0.0.1") + (Just "8080") + let serverAddr = head serverAddrs + sock <- socket (addrFamily serverAddr) Stream defaultProtocol + + N.connect sock (addrAddress serverAddr) + + ping sock pings + putMVar clientDone () + + -- Wait for the client to finish + takeMVar clientDone + +pingMessage :: ByteString +pingMessage = pack "ping123" + +ping :: Socket -> Int -> IO () +ping sock pings = go pings + where + go :: Int -> IO () + go 0 = do + putStrLn $ "client did " ++ show pings ++ " pings" + go !i = do + before <- getCurrentTime + send sock pingMessage + bs <- recv sock 8 + after <- getCurrentTime + -- putStrLn $ "client received " ++ unpack bs + let latency = (1e6 :: Double) * realToFrac (diffUTCTime after before) + hPutStrLn stderr $ show i ++ " " ++ show latency + go (i - 1) + +pong :: Socket -> IO () +pong sock = do + bs <- recv sock 8 + -- putStrLn $ "server received " ++ unpack bs + when (BS.length bs > 0) $ do + send sock bs + pong sock + +-- | Wrapper around NBS.recv (for profiling) +recv :: Socket -> Int -> IO ByteString +recv = NBS.recv + +-- | Wrapper around NBS.send (for profiling) +send :: Socket -> ByteString -> IO Int +ggsend = NBS.send diff --git a/packages/network-transport-tcp/benchmarks/JustPingOneRecv.hs b/packages/network-transport-tcp/benchmarks/JustPingOneRecv.hs new file mode 100644 index 00000000..accc287d --- /dev/null +++ b/packages/network-transport-tcp/benchmarks/JustPingOneRecv.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE CPP, BangPatterns #-} + +module Main where + +import Control.Monad + +import Data.Int +import Network.Socket + ( AddrInfoFlag (AI_PASSIVE), HostName, ServiceName, Socket + , SocketType (Stream), SocketOption (ReuseAddr) + , accept, addrAddress, addrFlags, addrFamily, bindSocket, defaultProtocol + , defaultHints + , getAddrInfo, listen, setSocketOption, socket, sClose, withSocketsDo ) +import System.Environment (getArgs, withArgs) +import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime) +import System.IO (withFile, IOMode(..), hPutStrLn, Handle, stderr) +import Control.Concurrent (forkIO) +import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar) +import qualified Network.Socket as N +import Debug.Trace +import Data.ByteString (ByteString) +import Data.ByteString.Char8 (pack, unpack) +import qualified Data.ByteString as BS +import qualified Network.Socket.ByteString as NBS +import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime) +import Data.ByteString.Internal as BSI +import Foreign.Storable (pokeByteOff, peekByteOff) +import Foreign.C (CInt(..)) +import Foreign.ForeignPtr (withForeignPtr) + +foreign import ccall unsafe "htonl" htonl :: CInt -> CInt +foreign import ccall unsafe "ntohl" ntohl :: CInt -> CInt + +main :: IO () +main = do + [pingsStr] <- getArgs + serverReady <- newEmptyMVar + clientDone <- newEmptyMVar + + -- Start the server + forkIO $ do + putStrLn "server: creating TCP connection" + serverAddrs <- getAddrInfo + (Just (defaultHints { addrFlags = [AI_PASSIVE] } )) + Nothing + (Just "8080") + let serverAddr = head serverAddrs + sock <- socket (addrFamily serverAddr) Stream defaultProtocol + setSocketOption sock ReuseAddr 1 + bindSocket sock (addrAddress serverAddr) + + putStrLn "server: awaiting client connection" + putMVar serverReady () + listen sock 1 + (clientSock, clientAddr) <- accept sock + + putStrLn "server: listening for pings" + pong clientSock + + -- Start the client + forkIO $ do + takeMVar serverReady + let pings = read pingsStr + serverAddrs <- getAddrInfo + Nothing + (Just "127.0.0.1") + (Just "8080") + let serverAddr = head serverAddrs + sock <- socket (addrFamily serverAddr) Stream defaultProtocol + + N.connect sock (addrAddress serverAddr) + + ping sock pings + putMVar clientDone () + + -- Wait for the client to finish + takeMVar clientDone + +pingMessage :: ByteString +pingMessage = pack "ping123" + +ping :: Socket -> Int -> IO () +ping sock pings = go pings + where + go :: Int -> IO () + go 0 = do + putStrLn $ "client did " ++ show pings ++ " pings" + go !i = do + before <- getCurrentTime + send sock pingMessage + bs <- recv sock 8 + after <- getCurrentTime + -- putStrLn $ "client received " ++ unpack bs + let latency = (1e6 :: Double) * realToFrac (diffUTCTime after before) + hPutStrLn stderr $ show i ++ " " ++ show latency + go (i - 1) + +pong :: Socket -> IO () +pong sock = do + bs <- recv sock 8 + -- putStrLn $ "server received " ++ unpack bs + when (BS.length bs > 0) $ do + send sock bs + pong sock + +-- | Wrapper around NBS.recv (for profiling) +recv :: Socket -> Int -> IO ByteString +recv sock i = do + (header, payload) <- BS.splitAt 4 `fmap` NBS.recv sock (4 + i) + length <- decodeLength header -- Ignored + return payload + +-- | Wrapper around NBS.send (for profiling) +send :: Socket -> ByteString -> IO () +send sock bs = do + length <- encodeLength (fromIntegral (BS.length bs)) + NBS.sendMany sock [length, bs] + +-- | Encode length (manual for now) +encodeLength :: Int32 -> IO ByteString +encodeLength i32 = + BSI.create 4 $ \p -> + pokeByteOff p 0 (htonl (fromIntegral i32)) + +-- | Decode length (manual for now) +decodeLength :: ByteString -> IO Int32 +decodeLength bs = + let (fp, _, _) = BSI.toForeignPtr bs in + withForeignPtr fp $ \p -> do + w32 <- peekByteOff p 0 + return (fromIntegral (ntohl w32)) diff --git a/packages/network-transport-tcp/benchmarks/JustPingThroughChan.hs b/packages/network-transport-tcp/benchmarks/JustPingThroughChan.hs new file mode 100644 index 00000000..044d5380 --- /dev/null +++ b/packages/network-transport-tcp/benchmarks/JustPingThroughChan.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE CPP, BangPatterns #-} + +module Main where + +import Control.Monad + +import Data.Int +import Network.Socket + ( AddrInfo, AddrInfoFlag (AI_PASSIVE), HostName, ServiceName, Socket + , SocketType (Stream), SocketOption (ReuseAddr) + , accept, addrAddress, addrFlags, addrFamily, bindSocket, defaultProtocol + , defaultHints + , getAddrInfo, listen, setSocketOption, socket, sClose, withSocketsDo ) +import System.Environment (getArgs, withArgs) +import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime) +import System.IO (withFile, IOMode(..), hPutStrLn, Handle, stderr) +import Control.Concurrent (forkIO) +import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar) +import qualified Network.Socket as N +import Debug.Trace +import Data.ByteString (ByteString) +import Data.ByteString.Char8 (pack, unpack) +import qualified Data.ByteString as BS +import qualified Network.Socket.ByteString as NBS +import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime) +import Data.ByteString.Internal as BSI +import Foreign.Storable (pokeByteOff, peekByteOff) +import Foreign.C (CInt(..)) +import Foreign.ForeignPtr (withForeignPtr) +import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan) + +foreign import ccall unsafe "htonl" htonl :: CInt -> CInt +foreign import ccall unsafe "ntohl" ntohl :: CInt -> CInt + +passive :: Maybe AddrInfo +passive = Just (defaultHints { addrFlags = [AI_PASSIVE] }) + +main = do + [pingsStr] <- getArgs + serverReady <- newEmptyMVar + clientDone <- newEmptyMVar + + -- Start the server + forkIO $ do + -- Initialize the server + serverAddr:_ <- getAddrInfo passive Nothing (Just "8080") + sock <- socket (addrFamily serverAddr) Stream defaultProtocol + setSocketOption sock ReuseAddr 1 + bindSocket sock (addrAddress serverAddr) + listen sock 1 + + -- Set up multiplexing channel + multiplexChannel <- newChan + + -- Wait for incoming connections (pings from the client) + putMVar serverReady () + (clientSock, pingAddr) <- accept sock + forkIO $ socketToChan clientSock multiplexChannel + + -- Reply to the client + forever $ readChan multiplexChannel >>= send clientSock + + -- Start the client + forkIO $ do + takeMVar serverReady + serverAddr:_ <- getAddrInfo Nothing (Just "127.0.0.1") (Just "8080") + clientSock <- socket (addrFamily serverAddr) Stream defaultProtocol + N.connect clientSock (addrAddress serverAddr) + ping clientSock (read pingsStr) + putMVar clientDone () + + -- Wait for the client to finish + takeMVar clientDone + +socketToChan :: Socket -> Chan ByteString -> IO () +socketToChan sock chan = go + where + go = do bs <- recv sock + when (BS.length bs > 0) $ do + writeChan chan bs + go + +pingMessage :: ByteString +pingMessage = pack "ping123" + +ping :: Socket -> Int -> IO () +ping sock pings = go pings + where + go :: Int -> IO () + go 0 = do + putStrLn $ "client did " ++ show pings ++ " pings" + go !i = do + before <- getCurrentTime + send sock pingMessage + bs <- recv sock + after <- getCurrentTime + -- putStrLn $ "client received " ++ unpack bs + let latency = (1e6 :: Double) * realToFrac (diffUTCTime after before) + hPutStrLn stderr $ show i ++ " " ++ show latency + go (i - 1) + +-- | Receive a package +recv :: Socket -> IO ByteString +recv sock = do + header <- NBS.recv sock 4 + length <- decodeLength header + NBS.recv sock (fromIntegral (length :: Int32)) + +-- | Send a package +send :: Socket -> ByteString -> IO () +send sock bs = do + length <- encodeLength (fromIntegral (BS.length bs)) + NBS.sendMany sock [length, bs] + +-- | Encode length (manual for now) +encodeLength :: Int32 -> IO ByteString +encodeLength i32 = + BSI.create 4 $ \p -> + pokeByteOff p 0 (htonl (fromIntegral i32)) + +-- | Decode length (manual for now) +decodeLength :: ByteString -> IO Int32 +decodeLength bs = + let (fp, _, _) = BSI.toForeignPtr bs in + withForeignPtr fp $ \p -> do + w32 <- peekByteOff p 0 + return (fromIntegral (ntohl w32)) diff --git a/packages/network-transport-tcp/benchmarks/JustPingThroughMVar.hs b/packages/network-transport-tcp/benchmarks/JustPingThroughMVar.hs new file mode 100644 index 00000000..c1caffe2 --- /dev/null +++ b/packages/network-transport-tcp/benchmarks/JustPingThroughMVar.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE CPP, BangPatterns #-} + +module Main where + +import Control.Monad + +import Data.Int +import Network.Socket + ( AddrInfo, AddrInfoFlag (AI_PASSIVE), HostName, ServiceName, Socket + , SocketType (Stream), SocketOption (ReuseAddr) + , accept, addrAddress, addrFlags, addrFamily, bindSocket, defaultProtocol + , defaultHints + , getAddrInfo, listen, setSocketOption, socket, sClose, withSocketsDo ) +import System.Environment (getArgs, withArgs) +import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime) +import System.IO (withFile, IOMode(..), hPutStrLn, Handle, stderr) +import Control.Concurrent (forkIO) +import Control.Concurrent.MVar (MVar, newEmptyMVar, takeMVar, putMVar) +import qualified Network.Socket as N +import Debug.Trace +import Data.ByteString (ByteString) +import Data.ByteString.Char8 (pack, unpack) +import qualified Data.ByteString as BS +import qualified Network.Socket.ByteString as NBS +import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime) +import Data.ByteString.Internal as BSI +import Foreign.Storable (pokeByteOff, peekByteOff) +import Foreign.C (CInt(..)) +import Foreign.ForeignPtr (withForeignPtr) +import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan) + +foreign import ccall unsafe "htonl" htonl :: CInt -> CInt +foreign import ccall unsafe "ntohl" ntohl :: CInt -> CInt + +passive :: Maybe AddrInfo +passive = Just (defaultHints { addrFlags = [AI_PASSIVE] }) + +main = do + [pingsStr] <- getArgs + serverReady <- newEmptyMVar + clientDone <- newEmptyMVar + + -- Start the server + forkIO $ do + -- Initialize the server + serverAddr:_ <- getAddrInfo passive Nothing (Just "8080") + sock <- socket (addrFamily serverAddr) Stream defaultProtocol + setSocketOption sock ReuseAddr 1 + bindSocket sock (addrAddress serverAddr) + listen sock 1 + + -- Set up multiplexing channel + multiplexMVar <- newEmptyMVar + + -- Wait for incoming connections (pings from the client) + putMVar serverReady () + (clientSock, pingAddr) <- accept sock + forkIO $ socketToMVar clientSock multiplexMVar + + -- Reply to the client + forever $ takeMVar multiplexMVar >>= send clientSock + + -- Start the client + forkIO $ do + takeMVar serverReady + serverAddr:_ <- getAddrInfo Nothing (Just "127.0.0.1") (Just "8080") + clientSock <- socket (addrFamily serverAddr) Stream defaultProtocol + N.connect clientSock (addrAddress serverAddr) + ping clientSock (read pingsStr) + putMVar clientDone () + + -- Wait for the client to finish + takeMVar clientDone + +socketToMVar :: Socket -> MVar ByteString -> IO () +socketToMVar sock mvar = go + where + go = do bs <- recv sock + when (BS.length bs > 0) $ do + putMVar mvar bs + go + +pingMessage :: ByteString +pingMessage = pack "ping123" + +ping :: Socket -> Int -> IO () +ping sock pings = go pings + where + go :: Int -> IO () + go 0 = do + putStrLn $ "client did " ++ show pings ++ " pings" + go !i = do + before <- getCurrentTime + send sock pingMessage + bs <- recv sock + after <- getCurrentTime + -- putStrLn $ "client received " ++ unpack bs + let latency = (1e6 :: Double) * realToFrac (diffUTCTime after before) + hPutStrLn stderr $ show i ++ " " ++ show latency + go (i - 1) + +-- | Receive a package +recv :: Socket -> IO ByteString +recv sock = do + header <- NBS.recv sock 4 + length <- decodeLength header + NBS.recv sock (fromIntegral (length :: Int32)) + +-- | Send a package +send :: Socket -> ByteString -> IO () +send sock bs = do + length <- encodeLength (fromIntegral (BS.length bs)) + NBS.sendMany sock [length, bs] + +-- | Encode length (manual for now) +encodeLength :: Int32 -> IO ByteString +encodeLength i32 = + BSI.create 4 $ \p -> + pokeByteOff p 0 (htonl (fromIntegral i32)) + +-- | Decode length (manual for now) +decodeLength :: ByteString -> IO Int32 +decodeLength bs = + let (fp, _, _) = BSI.toForeignPtr bs in + withForeignPtr fp $ \p -> do + w32 <- peekByteOff p 0 + return (fromIntegral (ntohl w32)) diff --git a/packages/network-transport-tcp/benchmarks/JustPingTransport.hs b/packages/network-transport-tcp/benchmarks/JustPingTransport.hs new file mode 100644 index 00000000..bf088975 --- /dev/null +++ b/packages/network-transport-tcp/benchmarks/JustPingTransport.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE CPP, BangPatterns #-} + +module Main where + +import Control.Monad + +import Data.Int +import System.Environment (getArgs, withArgs) +import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime) +import System.IO (withFile, IOMode(..), hPutStrLn, Handle, stderr) +import Control.Concurrent (forkIO) +import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar) +import qualified Network.Socket as N +import Debug.Trace +import Data.ByteString (ByteString) +import Data.ByteString.Char8 (pack, unpack) +import qualified Data.ByteString as BS +import qualified Network.Socket.ByteString as NBS +import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime) +import Network.Transport +import Network.Transport.TCP + +main :: IO () +main = do + [pingsStr] <- getArgs + serverAddr <- newEmptyMVar + clientAddr <- newEmptyMVar + clientDone <- newEmptyMVar + + -- Start the server + forkIO $ do + -- establish transport and endpoint + putStrLn "server: creating TCP connection" + Right transport <- createTransport "127.0.0.1" "8080" defaultTCPParameters + Right endpoint <- newEndPoint transport + putMVar serverAddr (address endpoint) + + -- Connect to the client so that we can reply + theirAddr <- takeMVar clientAddr + Right conn <- connect endpoint theirAddr ReliableOrdered defaultConnectHints + + -- reply to pings with pongs + putStrLn "server: awaiting client connection" + ConnectionOpened _ _ _ <- receive endpoint + pong endpoint conn + + -- Start the client + forkIO $ do + let pings = read pingsStr + + -- establish transport and endpoint + Right transport <- createTransport "127.0.0.1" "8081" defaultTCPParameters + Right endpoint <- newEndPoint transport + putMVar clientAddr (address endpoint) + + -- Connect to the server to send pings + theirAddr <- takeMVar serverAddr + Right conn <- connect endpoint theirAddr ReliableOrdered defaultConnectHints + + -- Send pings, waiting for a reply after every ping + ConnectionOpened _ _ _ <- receive endpoint + ping endpoint conn pings + putMVar clientDone () + + -- Wait for the client to finish + takeMVar clientDone + +pingMessage :: [ByteString] +pingMessage = [pack "ping123"] + +ping :: EndPoint -> Connection -> Int -> IO () +ping endpoint conn pings = go pings + where + go :: Int -> IO () + go 0 = do + putStrLn $ "client did " ++ show pings ++ " pings" + go !i = do + before <- getCurrentTime + send conn pingMessage + Received _ _payload <- receive endpoint + after <- getCurrentTime + -- putStrLn $ "client received " ++ show _payload + let latency = (1e6 :: Double) * realToFrac (diffUTCTime after before) + hPutStrLn stderr $ show i ++ " " ++ show latency + go (i - 1) + +pong :: EndPoint -> Connection -> IO () +pong endpoint conn = go + where + go = do + msg <- receive endpoint + case msg of + Received _ payload -> send conn payload >> go + ConnectionClosed _ -> return () + _ -> fail "Unexpected message" diff --git a/packages/network-transport-tcp/benchmarks/JustPingTwoSocketPairs.hs b/packages/network-transport-tcp/benchmarks/JustPingTwoSocketPairs.hs new file mode 100644 index 00000000..1850aef5 --- /dev/null +++ b/packages/network-transport-tcp/benchmarks/JustPingTwoSocketPairs.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE CPP, BangPatterns #-} + +module Main where + +import Control.Monad + +import Data.Int +import Network.Socket + ( AddrInfo, AddrInfoFlag (AI_PASSIVE), HostName, ServiceName, Socket + , SocketType (Stream), SocketOption (ReuseAddr, NoDelay) + , accept, addrAddress, addrFlags, addrFamily, bindSocket, defaultProtocol + , defaultHints + , getAddrInfo, listen, setSocketOption, socket, sClose, withSocketsDo ) +import System.Environment (getArgs, withArgs) +import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime) +import System.IO (withFile, IOMode(..), hPutStrLn, Handle, stderr) +import Control.Concurrent (forkIO) +import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar) +import qualified Network.Socket as N +import Debug.Trace +import Data.ByteString (ByteString) +import Data.ByteString.Char8 (pack, unpack) +import qualified Data.ByteString as BS +import qualified Network.Socket.ByteString as NBS +import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime) +import Data.ByteString.Internal as BSI +import Foreign.Storable (pokeByteOff, peekByteOff) +import Foreign.C (CInt(..)) +import Foreign.ForeignPtr (withForeignPtr) +import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan) + +foreign import ccall unsafe "htonl" htonl :: CInt -> CInt +foreign import ccall unsafe "ntohl" ntohl :: CInt -> CInt + +passive :: Maybe AddrInfo +passive = Just (defaultHints { addrFlags = [AI_PASSIVE] }) + +main = do + pingsStr:args <- getArgs + serverReady <- newEmptyMVar + clientReady <- newEmptyMVar + clientDone <- newEmptyMVar + + -- Start the server + forkIO $ do + -- Initialize the server + serverAddr:_ <- getAddrInfo passive Nothing (Just "8080") + sock <- socket (addrFamily serverAddr) Stream defaultProtocol + setSocketOption sock ReuseAddr 1 + bindSocket sock (addrAddress serverAddr) + listen sock 1 + + -- Set up multiplexing channel + multiplexChannel <- newChan + + -- Connect to the client (to reply) + forkIO $ do + takeMVar clientReady + clientAddr:_ <- getAddrInfo Nothing (Just "127.0.0.1") (Just "8081") + pongSock <- socket (addrFamily clientAddr) Stream defaultProtocol + N.connect pongSock (addrAddress clientAddr) + when ("--NoDelay" `elem` args) $ setSocketOption pongSock NoDelay 1 + forever $ readChan multiplexChannel >>= send pongSock + + -- Wait for incoming connections (pings from the client) + putMVar serverReady () + (pingSock, pingAddr) <- accept sock + socketToChan pingSock multiplexChannel + + -- Start the client + forkIO $ do + clientAddr:_ <- getAddrInfo passive Nothing (Just "8081") + sock <- socket (addrFamily clientAddr) Stream defaultProtocol + setSocketOption sock ReuseAddr 1 + bindSocket sock (addrAddress clientAddr) + listen sock 1 + + -- Set up multiplexing channel + multiplexChannel <- newChan + + -- Connect to the server (to send pings) + forkIO $ do + takeMVar serverReady + serverAddr:_ <- getAddrInfo Nothing (Just "127.0.0.1") (Just "8080") + pingSock <- socket (addrFamily serverAddr) Stream defaultProtocol + N.connect pingSock (addrAddress serverAddr) + when ("--NoDelay" `elem` args) $ setSocketOption pingSock NoDelay 1 + ping pingSock multiplexChannel (read pingsStr) + putMVar clientDone () + + -- Wait for incoming connections (pongs from the server) + putMVar clientReady () + (pongSock, pongAddr) <- accept sock + socketToChan pongSock multiplexChannel + + -- Wait for the client to finish + takeMVar clientDone + +socketToChan :: Socket -> Chan ByteString -> IO () +socketToChan sock chan = go + where + go = do bs <- recv sock + when (BS.length bs > 0) $ do + writeChan chan bs + go + +pingMessage :: ByteString +pingMessage = pack "ping123" + +ping :: Socket -> Chan ByteString -> Int -> IO () +ping sock chan pings = go pings + where + go :: Int -> IO () + go 0 = do + putStrLn $ "client did " ++ show pings ++ " pings" + go !i = do + before <- getCurrentTime + send sock pingMessage + bs <- readChan chan + after <- getCurrentTime + -- putStrLn $ "client received " ++ unpack bs + let latency = (1e6 :: Double) * realToFrac (diffUTCTime after before) + hPutStrLn stderr $ show i ++ " " ++ show latency + go (i - 1) + +-- | Receive a package +recv :: Socket -> IO ByteString +recv sock = do + header <- NBS.recv sock 4 + length <- decodeLength header + NBS.recv sock (fromIntegral (length :: Int32)) + +-- | Send a package +send :: Socket -> ByteString -> IO () +send sock bs = do + length <- encodeLength (fromIntegral (BS.length bs)) + NBS.sendMany sock [length, bs] + +-- | Encode length (manual for now) +encodeLength :: Int32 -> IO ByteString +encodeLength i32 = + BSI.create 4 $ \p -> + pokeByteOff p 0 (htonl (fromIntegral i32)) + +-- | Decode length (manual for now) +decodeLength :: ByteString -> IO Int32 +decodeLength bs = + let (fp, _, _) = BSI.toForeignPtr bs in + withForeignPtr fp $ \p -> do + w32 <- peekByteOff p 0 + return (fromIntegral (ntohl w32)) diff --git a/packages/network-transport-tcp/benchmarks/JustPingWithHeader.hs b/packages/network-transport-tcp/benchmarks/JustPingWithHeader.hs new file mode 100644 index 00000000..b33b91b7 --- /dev/null +++ b/packages/network-transport-tcp/benchmarks/JustPingWithHeader.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE CPP, BangPatterns #-} + +module Main where + +import Control.Monad + +import Data.Int +import Network.Socket + ( AddrInfoFlag (AI_PASSIVE), HostName, ServiceName, Socket + , SocketType (Stream), SocketOption (ReuseAddr) + , accept, addrAddress, addrFlags, addrFamily, bindSocket, defaultProtocol + , defaultHints + , getAddrInfo, listen, setSocketOption, socket, sClose, withSocketsDo ) +import System.Environment (getArgs, withArgs) +import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime) +import System.IO (withFile, IOMode(..), hPutStrLn, Handle, stderr) +import Control.Concurrent (forkIO) +import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar) +import qualified Network.Socket as N +import Debug.Trace +import Data.ByteString (ByteString) +import Data.ByteString.Char8 (pack, unpack) +import qualified Data.ByteString as BS +import qualified Network.Socket.ByteString as NBS +import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime) +import Data.ByteString.Internal as BSI +import Foreign.Storable (pokeByteOff, peekByteOff) +import Foreign.C (CInt(..)) +import Foreign.ForeignPtr (withForeignPtr) + +foreign import ccall unsafe "htonl" htonl :: CInt -> CInt +foreign import ccall unsafe "ntohl" ntohl :: CInt -> CInt + +main :: IO () +main = do + [pingsStr] <- getArgs + serverReady <- newEmptyMVar + clientDone <- newEmptyMVar + + -- Start the server + forkIO $ do + putStrLn "server: creating TCP connection" + serverAddrs <- getAddrInfo + (Just (defaultHints { addrFlags = [AI_PASSIVE] } )) + Nothing + (Just "8080") + let serverAddr = head serverAddrs + sock <- socket (addrFamily serverAddr) Stream defaultProtocol + setSocketOption sock ReuseAddr 1 + bindSocket sock (addrAddress serverAddr) + + putStrLn "server: awaiting client connection" + putMVar serverReady () + listen sock 1 + (clientSock, clientAddr) <- accept sock + + putStrLn "server: listening for pings" + pong clientSock + + -- Start the client + forkIO $ do + takeMVar serverReady + let pings = read pingsStr + serverAddrs <- getAddrInfo + Nothing + (Just "127.0.0.1") + (Just "8080") + let serverAddr = head serverAddrs + sock <- socket (addrFamily serverAddr) Stream defaultProtocol + + N.connect sock (addrAddress serverAddr) + + ping sock pings + putMVar clientDone () + + -- Wait for the client to finish + takeMVar clientDone + +pingMessage :: ByteString +pingMessage = pack "ping123" + +ping :: Socket -> Int -> IO () +ping sock pings = go pings + where + go :: Int -> IO () + go 0 = do + putStrLn $ "client did " ++ show pings ++ " pings" + go !i = do + before <- getCurrentTime + send sock pingMessage + bs <- recv sock 8 + after <- getCurrentTime + -- putStrLn $ "client received " ++ unpack bs + let latency = (1e6 :: Double) * realToFrac (diffUTCTime after before) + hPutStrLn stderr $ show i ++ " " ++ show latency + go (i - 1) + +pong :: Socket -> IO () +pong sock = do + bs <- recv sock 8 + -- putStrLn $ "server received " ++ unpack bs + when (BS.length bs > 0) $ do + send sock bs + pong sock + +-- | Wrapper around NBS.recv (for profiling) +recv :: Socket -> Int -> IO ByteString +recv sock _ = do + header <- NBS.recv sock 4 + length <- decodeLength header + NBS.recv sock (fromIntegral (length :: Int32)) + +-- | Wrapper around NBS.send (for profiling) +send :: Socket -> ByteString -> IO () +send sock bs = do + length <- encodeLength (fromIntegral (BS.length bs)) + NBS.sendMany sock [length, bs] + +-- | Encode length (manual for now) +encodeLength :: Int32 -> IO ByteString +encodeLength i32 = + BSI.create 4 $ \p -> + pokeByteOff p 0 (htonl (fromIntegral i32)) + +-- | Decode length (manual for now) +decodeLength :: ByteString -> IO Int32 +decodeLength bs = + let (fp, _, _) = BSI.toForeignPtr bs in + withForeignPtr fp $ \p -> do + w32 <- peekByteOff p 0 + return (fromIntegral (ntohl w32)) diff --git a/packages/network-transport-tcp/benchmarks/Makefile b/packages/network-transport-tcp/benchmarks/Makefile new file mode 100644 index 00000000..18458668 --- /dev/null +++ b/packages/network-transport-tcp/benchmarks/Makefile @@ -0,0 +1,58 @@ +# The "Just Ping" tests measure ping latency with as little overhead as possible + +NUMPINGS=100000 +ROOT=../.. +INCLUDES=-i${ROOT}/network-transport/src -i${ROOT}/network-transport-tcp/src + +# Enable for profiling +# PROF_GHC=-prof -fprof-auto +# PROF_EXE=+RTS -pa -RTS + +GCC=gcc +GHC=ghc -rtsopts -XRankNTypes -XScopedTypeVariables -XDeriveDataTypeable -XCPP -XGeneralizedNewtypeDeriving -optP-include -optPcabal_macros.h + +all: NewTransport.ps Indirection.ps Headers.ps + +Threaded.ps: JustPingC.data JustPingHaskellNT.data JustPingHaskell.data + gnuplot ./Threaded.gnuplot + +NewTransport.ps: JustPingHaskell.data \ + JustPingTransport.data + gnuplot ./NewTransport.gnuplot + +Indirection.ps: JustPingWithHeader.data \ + JustPingThroughChan.data \ + JustPingThroughMVar.data \ + JustPingTwoSocketPairs.data \ + JustPingTwoSocketPairsND.data \ + JustPingTransport.data + gnuplot ./Indirection.gnuplot + +Headers.ps: JustPingC.data \ + JustPingHaskellNT.data \ + JustPingHaskell.data \ + JustPingWithHeader.data \ + JustPingOneRecv.data \ + JustPingCacheHeader.data + gnuplot ./Headers.gnuplot + +JustPingC.exe: JustPingC.c + $(GCC) -O2 -o JustPingC.exe JustPingC.c + +JustPingHaskellNT.exe: JustPingHaskell.hs + $(GHC) -O2 $(PROF_GHC) -o JustPingHaskellNT.exe JustPingHaskell.hs + +JustPingTwoSocketPairsND.data: JustPingTwoSocketPairs.exe + time ./$< $(NUMPINGS) --NoDelay $(PROF_EXE) 2>$@ + +%.data : %.exe + time ./$< $(NUMPINGS) $(PROF_EXE) 2>$@ + +%.exe :: %.hs + $(GHC) -O2 $(PROF_GHC) -threaded -o $@ --make $< $(INCLUDES) + +.PHONY: clean +clean: + rm -f *.data *.ps *.pdf *.o *.hi *.exe + +# vi:set noexpandtab: diff --git a/packages/network-transport-tcp/benchmarks/NewTransport.gnuplot b/packages/network-transport-tcp/benchmarks/NewTransport.gnuplot new file mode 100644 index 00000000..cf69dbf3 --- /dev/null +++ b/packages/network-transport-tcp/benchmarks/NewTransport.gnuplot @@ -0,0 +1,8 @@ +set title "Roundtrip (us)" +set yrange [0:150] +plot "JustPingHaskell.data" smooth bezier with lines title "JustPingHaskell", \ + "JustPingTransport.data" smooth bezier with lines title "JustPingTransport" +set terminal postscript color +set output "NewTransport.ps" +plot "JustPingHaskell.data" smooth bezier with lines title "JustPingHaskell", \ + "JustPingTransport.data" smooth bezier with lines title "JustPingTransport" diff --git a/packages/network-transport-tcp/benchmarks/Threaded.gnuplot b/packages/network-transport-tcp/benchmarks/Threaded.gnuplot new file mode 100644 index 00000000..4ed67c05 --- /dev/null +++ b/packages/network-transport-tcp/benchmarks/Threaded.gnuplot @@ -0,0 +1,9 @@ +set xrange [0:100] +plot "JustPingC.data" u 2:(1./100000.) smooth cumulative title "C", \ + "JustPingHaskellNT.data" u 2:(1./100000.) smooth cumulative title "Haskell", \ + "JustPingHaskell.data" u 2:(1./100000.) smooth cumulative title "Haskell -threaded" +set terminal postscript color +set output "Threaded.ps" +plot "JustPingC.data" u 2:(1./100000.) smooth cumulative title "C", \ + "JustPingHaskellNT.data" u 2:(1./100000.) smooth cumulative title "Haskell", \ + "JustPingHaskell.data" u 2:(1./100000.) smooth cumulative title "Haskell -threaded" diff --git a/packages/network-transport-tcp/benchmarks/cabal_macros.h b/packages/network-transport-tcp/benchmarks/cabal_macros.h new file mode 100644 index 00000000..705542cc --- /dev/null +++ b/packages/network-transport-tcp/benchmarks/cabal_macros.h @@ -0,0 +1,5 @@ +#define VERSION_base "4.5.0.0" +#define MIN_VERSION_base(major1,major2,minor) (\ + (major1) < 4 || \ + (major1) == 4 && (major2) < 5 || \ + (major1) == 4 && (major2) == 5 && (minor) <= 0) diff --git a/packages/network-transport-tcp/network-transport-tcp.cabal b/packages/network-transport-tcp/network-transport-tcp.cabal new file mode 100644 index 00000000..4ba7803e --- /dev/null +++ b/packages/network-transport-tcp/network-transport-tcp.cabal @@ -0,0 +1,108 @@ +cabal-version: 3.0 +Name: network-transport-tcp +Version: 0.8.4 +Build-Type: Simple +License: BSD-3-Clause +License-file: LICENSE +Copyright: Well-Typed LLP, Tweag I/O Limited +Author: Duncan Coutts, Nicolas Wu, Edsko de Vries +maintainer: The Distributed Haskell team +Stability: experimental +Homepage: http://haskell-distributed.github.com +Bug-Reports: https://github.com/haskell-distributed/network-transport-tcp/issues +Synopsis: TCP instantiation of Network.Transport +Description: TCP instantiation of Network.Transport +tested-with: GHC==8.10.7 GHC==9.0.2 GHC==9.2.8 GHC==9.4.5 GHC==9.6.4 GHC==9.8.2 GHC==9.10.1 +Category: Network +extra-source-files: ChangeLog + +Source-Repository head + Type: git + Location: https://github.com/haskell-distributed/network-transport-tcp + +common warnings + ghc-options: -Wall + -Wcompat + -Widentities + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wredundant-constraints + -fhide-source-paths + -Wpartial-fields + +Flag use-mock-network + Description: Use mock network implementation (for testing) + Default: False + +Library + import: warnings + Build-Depends: base >= 4.14 && < 5, + async >= 2.2 && < 2.3, + network-transport >= 0.5 && < 0.6, + data-accessor >= 0.2 && < 0.3, + containers >= 0.6 && < 0.8, + bytestring >= 0.10 && < 0.13, + network >= 3.1 && < 3.3, + uuid >= 1.3 && < 1.4 + Exposed-modules: Network.Transport.TCP, + Network.Transport.TCP.Internal + Default-Extensions: CPP + default-language: Haskell2010 + Other-Extensions: RecursiveDo + ghc-options: -fno-warn-unused-do-bind + HS-Source-Dirs: src + If flag(use-mock-network) + CPP-Options: -DUSE_MOCK_NETWORK + Exposed-modules: Network.Transport.TCP.Mock.Socket + Network.Transport.TCP.Mock.Socket.ByteString + +Test-Suite TestTCP + import: warnings + Type: exitcode-stdio-1.0 + Main-Is: TestTCP.hs + Build-Depends: base >= 4.14 && < 5, + bytestring >= 0.10, + network-transport-tests >= 0.3 && < 0.4, + network >= 3.1, + network-transport, + network-transport-tcp + ghc-options: -threaded -rtsopts -with-rtsopts=-N + HS-Source-Dirs: tests + default-extensions: CPP, + OverloadedStrings + default-language: Haskell2010 + If flag(use-mock-network) + CPP-Options: -DUSE_MOCK_NETWORK + +Test-Suite TestQC + import: warnings + Type: exitcode-stdio-1.0 + Main-Is: TestQC.hs + If flag(use-mock-network) + Build-Depends: base >= 4.14 && < 5, + test-framework, + test-framework-quickcheck2, + test-framework-hunit, + QuickCheck, + HUnit, + network-transport, + network-transport-tcp, + containers, + bytestring, + pretty, + data-accessor, + data-accessor-transformers, + mtl, + transformers, + lockfree-queue + Else + Buildable: False + ghc-options: -threaded -Wall -fno-warn-orphans + HS-Source-Dirs: tests + default-extensions: TypeSynonymInstances + FlexibleInstances + OverlappingInstances + OverloadedStrings + DeriveDataTypeable + MultiParamTypeClasses + default-language: Haskell2010 diff --git a/packages/network-transport-tcp/src/Network/Transport/TCP.hs b/packages/network-transport-tcp/src/Network/Transport/TCP.hs new file mode 100644 index 00000000..99ae6192 --- /dev/null +++ b/packages/network-transport-tcp/src/Network/Transport/TCP.hs @@ -0,0 +1,2238 @@ +-- | TCP implementation of the transport layer. +-- +-- The TCP implementation guarantees that only a single TCP connection (socket) +-- will be used between endpoints, provided that the addresses specified are +-- canonical. If /A/ connects to /B/ and reports its address as +-- @192.168.0.1:8080@ and /B/ subsequently connects tries to connect to /A/ as +-- @client1.local:http-alt@ then the transport layer will not realize that the +-- TCP connection can be reused. +-- +-- Applications that use the TCP transport should use +-- 'Network.Socket.withSocketsDo' in their main function for Windows +-- compatibility (see "Network.Socket"). +{-# LANGUAGE CPP #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE LambdaCase #-} + +module Network.Transport.TCP + ( -- * Main API + createTransport + , TCPAddr(..) + , defaultTCPAddr + , TCPAddrInfo(..) + , TCPParameters(..) + , defaultTCPParameters + -- * Internals (exposed for unit tests) + , createTransportExposeInternals + , TransportInternals(..) + , EndPointId + , ControlHeader(..) + , ConnectionRequestResponse(..) + , firstNonReservedLightweightConnectionId + , firstNonReservedHeavyweightConnectionId + , socketToEndPoint + , LightweightConnectionId + , QDisc(..) + , simpleUnboundedQDisc + , simpleOnePlaceQDisc + -- * Design notes + -- $design + ) where + +import Prelude hiding + ( mapM_ + ) + +import Network.Transport +import Network.Transport.TCP.Internal + ( ControlHeader(..) + , encodeControlHeader + , decodeControlHeader + , ConnectionRequestResponse(..) + , encodeConnectionRequestResponse + , decodeConnectionRequestResponse + , forkServer + , recvWithLength + , recvExact + , recvWord32 + , encodeWord32 + , tryCloseSocket + , tryShutdownSocketBoth + , resolveSockAddr + , EndPointId + , encodeEndPointAddress + , decodeEndPointAddress + , currentProtocolVersion + , randomEndPointAddress + ) +import Network.Transport.Internal + ( prependLength + , mapIOException + , tryIO + , tryToEnum + , void + , timeoutMaybe + , asyncWhenCancelled + ) + +#ifdef USE_MOCK_NETWORK +import qualified Network.Transport.TCP.Mock.Socket as N +#else +import qualified Network.Socket as N +#endif + ( HostName + , ServiceName + , Socket + , getAddrInfo + , maxListenQueue + , socket + , addrFamily + , addrAddress + , SocketType(Stream) + , defaultProtocol + , setSocketOption + , SocketOption(ReuseAddr, NoDelay, UserTimeout, KeepAlive) + , isSupportedSocketOption + , connect + , AddrInfo + , SockAddr(..) + ) + +#ifdef USE_MOCK_NETWORK +import Network.Transport.TCP.Mock.Socket.ByteString (sendMany) +#else +import Network.Socket.ByteString (sendMany) +#endif + +import Control.Concurrent + ( forkIO + , ThreadId + , killThread + , myThreadId + , threadDelay + , throwTo + ) +import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan) +import Control.Concurrent.MVar + ( MVar + , newMVar + , modifyMVar + , modifyMVar_ + , readMVar + , tryReadMVar + , takeMVar + , putMVar + , tryPutMVar + , newEmptyMVar + , withMVar + ) +import Control.Concurrent.Async (async, wait) +import Control.Category ((>>>)) +import Control.Applicative ((<$>)) +import Control.Monad (when, unless, join, mplus, (<=<)) +import Control.Exception + ( IOException + , SomeException + , AsyncException + , handle + , throw + , throwIO + , try + , bracketOnError + , bracket + , fromException + , finally + , catch + , bracket + , mask + , mask_ + ) +import Data.IORef (IORef, newIORef, writeIORef, readIORef, writeIORef) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS (concat, length, null) +import qualified Data.ByteString.Char8 as BSC (pack, unpack) +import Data.Bits (shiftL, (.|.)) +import Data.Maybe (isJust, isNothing, fromJust) +import Data.Word (Word32) +import Data.Set (Set) +import qualified Data.Set as Set + ( empty + , insert + , elems + , singleton + , null + , delete + , member + ) +import Data.Map (Map) +import qualified Data.Map as Map (empty) +import Data.Traversable (traverse) +import Data.Accessor (Accessor, accessor, (^.), (^=), (^:)) +import qualified Data.Accessor.Container as DAC (mapMaybe) +import Data.Foldable (forM_, mapM_) +import qualified System.Timeout (timeout) + +-- $design +-- +-- [Goals] +-- +-- The TCP transport maps multiple logical connections between /A/ and /B/ (in +-- either direction) to a single TCP connection: +-- +-- > +-------+ +-------+ +-- > | A |==========================| B | +-- > | |>~~~~~~~~~~~~~~~~~~~~~~~~~|~~~\ | +-- > | Q |>~~~~~~~~~~~~~~~~~~~~~~~~~|~~~Q | +-- > | \~~~|~~~~~~~~~~~~~~~~~~~~~~~~~<| | +-- > | |==========================| | +-- > +-------+ +-------+ +-- +-- Ignoring the complications detailed below, the TCP connection is set up is +-- when the first lightweight connection is created (in either direction), and +-- torn down when the last lightweight connection (in either direction) is +-- closed. +-- +-- [Connecting] +-- +-- Let /A/, /B/ be two endpoints without any connections. When /A/ wants to +-- connect to /B/, it locally records that it is trying to connect to /B/ and +-- sends a request to /B/. As part of the request /A/ sends its own endpoint +-- address to /B/ (so that /B/ can reuse the connection in the other direction). +-- +-- When /B/ receives the connection request it first checks if it did not +-- already initiate a connection request to /A/. If not it will acknowledge the +-- connection request by sending 'ConnectionRequestAccepted' to /A/ and record +-- that it has a TCP connection to /A/. +-- +-- The tricky case arises when /A/ sends a connection request to /B/ and /B/ +-- finds that it had already sent a connection request to /A/. In this case /B/ +-- will accept the connection request from /A/ if /A/s endpoint address is +-- smaller (lexicographically) than /B/s, and reject it otherwise. If it rejects +-- it, it sends a 'ConnectionRequestCrossed' message to /A/. The +-- lexicographical ordering is an arbitrary but convenient way to break the +-- tie. If a connection exists between /A/ and /B/ when /B/ rejects the request, +-- /B/ will probe the connection to make sure it is healthy. If /A/ does not +-- answer timely to the probe, /B/ will discard the connection. +-- +-- When it receives a 'ConnectionRequestCrossed' message the /A/ thread that +-- initiated the request just needs to wait until the /A/ thread that is dealing +-- with /B/'s connection request completes, unless there is a network failure. +-- If there is a network failure, the initiator thread would timeout and return +-- an error. +-- +-- [Disconnecting] +-- +-- The TCP connection is created as soon as the first logical connection from +-- /A/ to /B/ (or /B/ to /A/) is established. At this point a thread (@#@) is +-- spawned that listens for incoming connections from /B/: +-- +-- > +-------+ +-------+ +-- > | A |==========================| B | +-- > | |>~~~~~~~~~~~~~~~~~~~~~~~~~|~~~\ | +-- > | | | Q | +-- > | #| | | +-- > | |==========================| | +-- > +-------+ +-------+ +-- +-- The question is when the TCP connection can be closed again. Conceptually, +-- we want to do reference counting: when there are no logical connections left +-- between /A/ and /B/ we want to close the socket (possibly after some +-- timeout). +-- +-- However, /A/ and /B/ need to agree that the refcount has reached zero. It +-- might happen that /B/ sends a connection request over the existing socket at +-- the same time that /A/ closes its logical connection to /B/ and closes the +-- socket. This will cause a failure in /B/ (which will have to retry) which is +-- not caused by a network failure, which is unfortunate. (Note that the +-- connection request from /B/ might succeed even if /A/ closes the socket.) +-- +-- Instead, when /A/ is ready to close the socket it sends a 'CloseSocket' +-- request to /B/ and records that its connection to /B/ is closing. If /A/ +-- receives a new connection request from /B/ after having sent the +-- 'CloseSocket' request it simply forgets that it sent a 'CloseSocket' request +-- and increments the reference count of the connection again. +-- +-- When /B/ receives a 'CloseSocket' message and it too is ready to close the +-- connection, it will respond with a reciprocal 'CloseSocket' request to /A/ +-- and then actually close the socket. /A/ meanwhile will not send any more +-- requests to /B/ after having sent a 'CloseSocket' request, and will actually +-- close its end of the socket only when receiving the 'CloseSocket' message +-- from /B/. (Since /A/ recorded that its connection to /B/ is in closing state +-- after sending a 'CloseSocket' request to /B/, it knows not to reciprocate /B/ +-- reciprocal 'CloseSocket' message.) +-- +-- If there is a concurrent thread in /A/ waiting to connect to /B/ after /A/ +-- has sent a 'CloseSocket' request then this thread will block until /A/ knows +-- whether to reuse the old socket (if /B/ sends a new connection request +-- instead of acknowledging the 'CloseSocket') or to set up a new socket. + +-------------------------------------------------------------------------------- +-- Internal datatypes -- +-------------------------------------------------------------------------------- + +-- We use underscores for fields that we might update (using accessors) +-- +-- All data types follow the same structure: +-- +-- * A top-level data type describing static properties (TCPTransport, +-- LocalEndPoint, RemoteEndPoint) +-- * The 'static' properties include an MVar containing a data structure for +-- the dynamic properties (TransportState, LocalEndPointState, +-- RemoteEndPointState). The state could be invalid/valid/closed,/etc. +-- * For the case of "valid" we use third data structure to give more details +-- about the state (ValidTransportState, ValidLocalEndPointState, +-- ValidRemoteEndPointState). + +-- | Information about the network addresses of a transport: the external +-- host/port as well as the bound host/port, which are not necessarily the +-- same. +data TransportAddrInfo = TransportAddrInfo + { transportHost :: !N.HostName + , transportPort :: !N.ServiceName + , transportBindHost :: !N.HostName + , transportBindPort :: !N.ServiceName + } + +data TCPTransport = TCPTransport + { transportAddrInfo :: !(Maybe TransportAddrInfo) + -- ^ This is 'Nothing' in case the transport is not addressable from the + -- network: peers cannot connect to it unless it has a connection to the + -- peer. + , transportState :: !(MVar TransportState) + , transportParams :: !TCPParameters + } + +data TransportState = + TransportValid !ValidTransportState + | TransportClosed + +data ValidTransportState = ValidTransportState + { _localEndPoints :: !(Map EndPointId LocalEndPoint) + , _nextEndPointId :: !EndPointId + } + +data LocalEndPoint = LocalEndPoint + { localAddress :: !EndPointAddress + , localEndPointId :: !EndPointId + , localState :: !(MVar LocalEndPointState) + -- | A 'QDisc' is held here rather than on the 'ValidLocalEndPointState' + -- because even closed 'LocalEndPoint's can have queued input data. + , localQueue :: !(QDisc Event) + } + +data LocalEndPointState = + LocalEndPointValid !ValidLocalEndPointState + | LocalEndPointClosed + +data ValidLocalEndPointState = ValidLocalEndPointState + { -- Next available ID for an outgoing lightweight self-connection + -- (see also remoteNextConnOutId) + _localNextConnOutId :: !LightweightConnectionId + -- Next available ID for an incoming heavyweight connection + , _nextConnInId :: !HeavyweightConnectionId + -- Currently active outgoing heavyweight connections + , _localConnections :: !(Map EndPointAddress RemoteEndPoint) + } + +-- REMOTE ENDPOINTS +-- +-- Remote endpoints (basically, TCP connections) have the following lifecycle: +-- +-- Init ---+---> Invalid +-- | +-- +-------------------------------\ +-- | | +-- | /----------\ | +-- | | | | +-- | v | v +-- +---> Valid ---> Closing ---> Closed +-- | | | | +-- | | | v +-- \-------+----------+--------> Failed +-- +-- Init: There are two places where we create new remote endpoints: in +-- createConnectionTo (in response to an API 'connect' call) and in +-- handleConnectionRequest (when a remote node tries to connect to us). +-- 'Init' carries an MVar () 'resolved' which concurrent threads can use to +-- wait for the remote endpoint to finish initialization. We record who +-- requested the connection (the local endpoint or the remote endpoint). +-- +-- Invalid: We put the remote endpoint in invalid state only during +-- createConnectionTo when we fail to connect. +-- +-- Valid: This is the "normal" state for a working remote endpoint. +-- +-- Closing: When we detect that a remote endpoint is no longer used, we send a +-- CloseSocket request across the connection and put the remote endpoint in +-- closing state. As with Init, 'Closing' carries an MVar () 'resolved' which +-- concurrent threads can use to wait for the remote endpoint to either be +-- closed fully (if the communication parnet responds with another +-- CloseSocket) or be put back in 'Valid' state if the remote endpoint denies +-- the request. +-- +-- We also put the endpoint in Closed state, directly from Init, if we our +-- outbound connection request crossed an inbound connection request and we +-- decide to keep the inbound (i.e., the remote endpoint sent us a +-- ConnectionRequestCrossed message). +-- +-- Closed: The endpoint is put in Closed state after a successful garbage +-- collection. +-- +-- Failed: If the connection to the remote endpoint is lost, or the local +-- endpoint (or the whole transport) is closed manually, the remote endpoint is +-- put in Failed state, and we record the reason. +-- +-- Invariants for dealing with remote endpoints: +-- +-- INV-SEND: Whenever we send data the remote endpoint must be locked (to avoid +-- interleaving bits of payload). +-- +-- INV-CLOSE: Local endpoints should never point to remote endpoint in closed +-- state. Whenever we put an endpoint in Closed state we remove that +-- endpoint from localConnections first, so that if a concurrent thread reads +-- the MVar, finds RemoteEndPointClosed, and then looks up the endpoint in +-- localConnections it is guaranteed to either find a different remote +-- endpoint, or else none at all (if we don't insist in this order some +-- threads might start spinning). +-- +-- INV-RESOLVE: We should only signal on 'resolved' while the remote endpoint is +-- locked, and the remote endpoint must be in Valid or Closed state once +-- unlocked. This guarantees that there will not be two threads attempting to +-- both signal on 'resolved'. +-- +-- INV-LOST: If a send or recv fails, or a socket is closed unexpectedly, we +-- first put the remote endpoint in Closed state, and then send a +-- EventConnectionLost event. This guarantees that we only send this event +-- once. +-- +-- INV-CLOSING: An endpoint in closing state is for all intents and purposes +-- closed; that is, we shouldn't do any 'send's on it (although 'recv' is +-- acceptable, of course -- as we are waiting for the remote endpoint to +-- confirm or deny the request). +-- +-- INV-LOCK-ORDER: Remote endpoint must be locked before their local endpoints. +-- In other words: it is okay to call modifyMVar on a local endpoint inside a +-- modifyMVar on a remote endpoint, but not the other way around. In +-- particular, it is okay to call removeRemoteEndPoint inside +-- modifyRemoteState. + +data RemoteEndPoint = RemoteEndPoint + { remoteAddress :: !EndPointAddress + , remoteState :: !(MVar RemoteState) + , remoteId :: !HeavyweightConnectionId + , remoteScheduled :: !(Chan (IO ())) + } + +data RequestedBy = RequestedByUs | RequestedByThem + deriving (Eq, Show) + +data RemoteState = + -- | Invalid remote endpoint (for example, invalid address) + RemoteEndPointInvalid !(TransportError ConnectErrorCode) + -- | The remote endpoint is being initialized + | RemoteEndPointInit !(MVar ()) !(MVar ()) !RequestedBy + -- | "Normal" working endpoint + | RemoteEndPointValid !ValidRemoteEndPointState + -- | The remote endpoint is being closed (garbage collected) + | RemoteEndPointClosing !(MVar ()) !ValidRemoteEndPointState + -- | The remote endpoint has been closed (garbage collected) + | RemoteEndPointClosed + -- | The remote endpoint has failed, or has been forcefully shutdown + -- using a closeTransport or closeEndPoint API call + | RemoteEndPointFailed !IOException + +-- TODO: we might want to replace Set (here and elsewhere) by faster +-- containers +-- +-- TODO: we could get rid of 'remoteIncoming' (and maintain less state) if +-- we introduce a new event 'AllConnectionsClosed' +data ValidRemoteEndPointState = ValidRemoteEndPointState + { _remoteOutgoing :: !Int + , _remoteIncoming :: !(Set LightweightConnectionId) + , _remoteLastIncoming :: !LightweightConnectionId + , _remoteNextConnOutId :: !LightweightConnectionId + , remoteSocket :: !N.Socket + -- | When the connection is being probed, yields an IO action that can be + -- used to release any resources dedicated to the probing. + , remoteProbing :: Maybe (IO ()) + -- | MVar protects the socket usage by the concurrent threads and + -- prohibits its usage after SomeException. + -- + -- Nothing allows the socket usage. @Just e@ is set on an + -- exception after which the socket should not be used (see 'sendOn'). + , remoteSendLock :: !(MVar (Maybe SomeException)) + -- | An IO which returns when the socket (remoteSocket) has been closed. + -- The program/thread which created the socket is always responsible + -- for closing it, but sometimes other threads need to know when this + -- happens. + , remoteSocketClosed :: !(IO ()) + } + +-- | Pair of local and a remote endpoint (for conciseness in signatures) +type EndPointPair = (LocalEndPoint, RemoteEndPoint) + +-- | Lightweight connection ID (sender allocated) +-- +-- A ConnectionId is the concentation of a 'HeavyweightConnectionId' and a +-- 'LightweightConnectionId'. +type LightweightConnectionId = Word32 + +-- | Heavyweight connection ID (recipient allocated) +-- +-- A ConnectionId is the concentation of a 'HeavyweightConnectionId' and a +-- 'LightweightConnectionId'. +type HeavyweightConnectionId = Word32 + +-- | A transport which is addressable from the network must give a host/port +-- on which to bind/listen, and determine its external address (host/port) from +-- the actual port (which may not be known, in case 0 is used for the bind +-- port). +data TCPAddrInfo = TCPAddrInfo { + tcpBindHost :: N.HostName + , tcpBindPort :: N.ServiceName + , tcpExternalAddress :: N.ServiceName -> (N.HostName, N.ServiceName) + } + +-- | Addressability of a transport. If your transport cannot be connected +-- to, for instance because it runs behind NAT, use Unaddressable. +data TCPAddr = Addressable TCPAddrInfo | Unaddressable + +-- | The bind and external host/port are the same. +defaultTCPAddr :: N.HostName -> N.ServiceName -> TCPAddr +defaultTCPAddr host port = Addressable $ TCPAddrInfo { + tcpBindHost = host + , tcpBindPort = port + , tcpExternalAddress = (,) host + } + +-- | Parameters for setting up the TCP transport +data TCPParameters = TCPParameters { + -- | Backlog for 'listen'. + -- Defaults to SOMAXCONN. + tcpBacklog :: Int + -- | Should we set SO_REUSEADDR on the server socket? + -- Defaults to True. + , tcpReuseServerAddr :: Bool + -- | Should we set SO_REUSEADDR on client sockets? + -- Defaults to True. + , tcpReuseClientAddr :: Bool + -- | Should we set TCP_NODELAY on connection sockets? + -- Defaults to True. + , tcpNoDelay :: Bool + -- | Should we set TCP_KEEPALIVE on connection sockets? + -- Defaults to False. + , tcpKeepAlive :: Bool + -- | Value of TCP_USER_TIMEOUT in milliseconds + , tcpUserTimeout :: Maybe Int + -- | A connect timeout for all 'connect' calls of the transport + -- in microseconds + -- + -- This can be overriden for each connect call with + -- 'ConnectHints'.'connectTimeout'. + -- + -- Connection requests to this transport will also timeout if they don't + -- send the required data before this many microseconds. + -- + -- Defaults to Nothing (no timeout). + , transportConnectTimeout :: Maybe Int + -- | Create a QDisc for an EndPoint. + , tcpNewQDisc :: forall t . IO (QDisc t) + -- | Maximum length (in bytes) for a peer's address. + -- If a peer attempts to send an address of length exceeding the limit, + -- the connection will be refused (socket will close). + , tcpMaxAddressLength :: Word32 + -- | Maximum length (in bytes) to receive from a peer. + -- If a peer attempts to send data on a lightweight connection exceeding + -- the limit, the heavyweight connection which carries that lightweight + -- connection will go down. The peer and the local node will get an + -- EventConnectionLost. + , tcpMaxReceiveLength :: Word32 + -- | If True, new connections will be accepted only if the socket's host + -- matches the host that the peer claims in its EndPointAddress. + -- This is useful when operating on untrusted networks, because the peer + -- could otherwise deny service to some victim by claiming the victim's + -- address. + -- Defaults to False. + , tcpCheckPeerHost :: Bool + -- | What to do if there's an exception when accepting a new TCP + -- connection. Throwing an exception here will cause the server to + -- terminate. + -- Defaults to `throwIO`. + , tcpServerExceptionHandler :: SomeException -> IO () + } + +-- | Internal functionality we expose for unit testing +data TransportInternals = TransportInternals + { -- | The ID of the thread that listens for new incoming connections + transportThread :: Maybe ThreadId + -- | A variant of newEndPoint in which the QDisc determined by the + -- transport's TCPParameters can be optionally overridden. + , newEndPointInternal :: (forall t . Maybe (QDisc t)) + -> IO (Either (TransportError NewEndPointErrorCode) EndPoint) + -- | Find the socket between a local and a remote endpoint + , socketBetween :: EndPointAddress + -> EndPointAddress + -> IO N.Socket + } + +-------------------------------------------------------------------------------- +-- Top-level functionality -- +-------------------------------------------------------------------------------- + +-- | Create a TCP transport +createTransport + :: TCPAddr + -> TCPParameters + -> IO (Either IOException Transport) +createTransport addr params = + either Left (Right . fst) <$> createTransportExposeInternals addr params + +-- | You should probably not use this function (used for unit testing only) +createTransportExposeInternals + :: TCPAddr + -> TCPParameters + -> IO (Either IOException (Transport, TransportInternals)) +createTransportExposeInternals addr params = do + state <- newMVar . TransportValid $ ValidTransportState + { _localEndPoints = Map.empty + , _nextEndPointId = 0 + } + case addr of + + Unaddressable -> + let transport = TCPTransport { transportState = state + , transportAddrInfo = Nothing + , transportParams = params + } + in fmap Right (mkTransport transport Nothing) + + Addressable (TCPAddrInfo bindHost bindPort mkExternal) -> tryIO $ mdo + when ( isJust (tcpUserTimeout params) && + not (N.isSupportedSocketOption N.UserTimeout) + ) $ + throwIO $ userError $ "Network.Transport.TCP.createTransport: " ++ + "the parameter tcpUserTimeout is unsupported " ++ + "in this system." + -- We don't know for sure the actual port 'forkServer' binded until it + -- completes (see description of 'forkServer'), yet we need the port to + -- construct a transport. So we tie a recursive knot. + (port', result) <- do + let (externalHost, externalPort) = mkExternal port' + let addrInfo = TransportAddrInfo { transportHost = externalHost + , transportPort = externalPort + , transportBindHost = bindHost + , transportBindPort = port' + } + let transport = TCPTransport { transportState = state + , transportAddrInfo = Just addrInfo + , transportParams = params + } + bracketOnError (forkServer + bindHost + bindPort + (tcpBacklog params) + (tcpReuseServerAddr params) + (errorHandler transport) + (terminationHandler transport) + (handleConnectionRequest transport)) + (\(_port', tid) -> killThread tid) + (\(port'', tid) -> (port'',) <$> mkTransport transport (Just tid)) + return result + where + mkTransport :: TCPTransport + -> Maybe ThreadId + -> IO (Transport, TransportInternals) + mkTransport transport mtid = do + return + ( Transport + { newEndPoint = do + qdisc <- tcpNewQDisc params + apiNewEndPoint transport qdisc + , closeTransport = let evs = [ EndPointClosed ] + in apiCloseTransport transport mtid evs + } + , TransportInternals + { transportThread = mtid + , socketBetween = internalSocketBetween transport + , newEndPointInternal = \mqdisc -> case mqdisc of + Just qdisc -> apiNewEndPoint transport qdisc + Nothing -> do + qdisc <- tcpNewQDisc params + apiNewEndPoint transport qdisc + } + ) + + errorHandler :: TCPTransport -> SomeException -> IO () + errorHandler _ = tcpServerExceptionHandler params + + terminationHandler :: TCPTransport -> SomeException -> IO () + terminationHandler transport ex = do + let evs = [ ErrorEvent (TransportError EventTransportFailed (show ex)) + , throw $ userError "Transport closed" + ] + apiCloseTransport transport Nothing evs + +-- | Default TCP parameters +defaultTCPParameters :: TCPParameters +defaultTCPParameters = TCPParameters { + tcpBacklog = N.maxListenQueue + , tcpReuseServerAddr = True + , tcpReuseClientAddr = True + , tcpNoDelay = True + , tcpKeepAlive = False + , tcpUserTimeout = Nothing + , tcpNewQDisc = simpleUnboundedQDisc + , transportConnectTimeout = Nothing + , tcpMaxAddressLength = maxBound + , tcpMaxReceiveLength = maxBound + , tcpCheckPeerHost = False + , tcpServerExceptionHandler = throwIO + } + +-------------------------------------------------------------------------------- +-- API functions -- +-------------------------------------------------------------------------------- + +-- | Close the transport +apiCloseTransport :: TCPTransport -> Maybe ThreadId -> [Event] -> IO () +apiCloseTransport transport mTransportThread evs = + asyncWhenCancelled return $ do + mTSt <- modifyMVar (transportState transport) $ \st -> case st of + TransportValid vst -> return (TransportClosed, Just vst) + TransportClosed -> return (TransportClosed, Nothing) + forM_ mTSt $ mapM_ (apiCloseEndPoint transport evs) . (^. localEndPoints) + -- This will invoke the termination handler, which in turn will call + -- apiCloseTransport again, but then the transport will already be closed + -- and we won't be passed a transport thread, so we terminate immmediate + forM_ mTransportThread killThread + +-- | Create a new endpoint +apiNewEndPoint :: TCPTransport + -> QDisc Event + -> IO (Either (TransportError NewEndPointErrorCode) EndPoint) +apiNewEndPoint transport qdisc = + try . asyncWhenCancelled closeEndPoint $ do + ourEndPoint <- createLocalEndPoint transport qdisc + return EndPoint + { receive = qdiscDequeue (localQueue ourEndPoint) + , address = localAddress ourEndPoint + , connect = apiConnect transport ourEndPoint + , closeEndPoint = let evs = [ EndPointClosed ] + in apiCloseEndPoint transport evs ourEndPoint + , newMulticastGroup = return . Left $ newMulticastGroupError + , resolveMulticastGroup = return . Left . const resolveMulticastGroupError + } + where + newMulticastGroupError = + TransportError NewMulticastGroupUnsupported "Multicast not supported" + resolveMulticastGroupError = + TransportError ResolveMulticastGroupUnsupported "Multicast not supported" + +-- | Abstraction of a queue for an 'EndPoint'. +-- +-- A value of type @QDisc t@ is a queue of events of an abstract type @t@. +-- +-- This specifies which 'Event's will come from +-- 'receive :: EndPoint -> IO Event' and when. It is highly general so that +-- the simple yet potentially very fast implementation backed by a single +-- unbounded channel can be used, without excluding more nuanced policies +-- like class-based queueing with bounded buffers for each peer, which may be +-- faster in certain conditions but probably has lower maximal throughput. +-- +-- A 'QDisc' must satisfy some properties in order for the semantics of +-- network-transport to hold true. In general, an event fed with +-- 'qdiscEnqueue' must not be dropped. i.e. provided that no other event in +-- the QDisc has higher priority, the event should eventually be returned by +-- 'qdiscDequeue'. An exception to this are 'Receive' events of unreliable +-- connections. +-- +-- Every call to 'receive' is just 'qdiscDequeue' on that 'EndPoint's +-- 'QDisc'. Whenever an event arises from a socket, `qdiscEnqueue` is called +-- with the relevant metadata in the same thread that reads from the socket. +-- You can be clever about when to block here, so as to control network +-- ingress. This applies also to loopback connections (an 'EndPoint' connects +-- to itself), in which case blocking on the enqueue would only block some +-- thread in your program rather than some chatty network peer. The 'Event' +-- which is to be enqueued is given to 'qdiscEnqueue' so that the 'QDisc' +-- can know about open connections, their identifiers and peer addresses, etc. +data QDisc t = QDisc { + -- | Dequeue an event. + qdiscDequeue :: IO t + -- | @qdiscEnqueue ep ev t@ enqueues and event @t@, originated from the + -- given remote endpoint @ep@ and with data @ev@. + -- + -- @ep@ might be the local endpoint if it relates to a self-connection. + -- + -- @ev@ might be in practice the value given as @t@. It is passed in + -- the abstract form @t@ to enforce it is dequeued unmodified, but the + -- 'QDisc' implementation can still observe the concrete form @ev@ to + -- make prioritization decisions. + , qdiscEnqueue :: EndPointAddress -> Event -> t -> IO () + } + +-- | Post an 'Event' using a 'QDisc'. +qdiscEnqueue' :: QDisc Event -> EndPointAddress -> Event -> IO () +qdiscEnqueue' qdisc addr event = qdiscEnqueue qdisc addr event event + +-- | A very simple QDisc backed by an unbounded channel. +simpleUnboundedQDisc :: forall t . IO (QDisc t) +simpleUnboundedQDisc = do + eventChan <- newChan + return $ QDisc { + qdiscDequeue = readChan eventChan + , qdiscEnqueue = const (const (writeChan eventChan)) + } + +-- | A very simple QDisc backed by a 1-place queue (MVar). +-- With this QDisc, all threads reading from sockets will try to put their +-- events into the same MVar. That MVar will be cleared by calls to +-- 'receive'. Thus the rate at which data is read from the wire is directly +-- related to the rate at which data is pulled from the EndPoint by +-- 'receive'. +simpleOnePlaceQDisc :: forall t . IO (QDisc t) +simpleOnePlaceQDisc = do + mvar <- newEmptyMVar + return $ QDisc { + qdiscDequeue = takeMVar mvar + , qdiscEnqueue = const (const (putMVar mvar)) + } + +-- | Connnect to an endpoint +apiConnect :: TCPTransport + -> LocalEndPoint -- ^ Local end point + -> EndPointAddress -- ^ Remote address + -> Reliability -- ^ Reliability (ignored) + -> ConnectHints -- ^ Hints + -> IO (Either (TransportError ConnectErrorCode) Connection) +apiConnect transport ourEndPoint theirAddress _reliability hints = + try . asyncWhenCancelled close $ + if localAddress ourEndPoint == theirAddress + then connectToSelf ourEndPoint + else do + resetIfBroken ourEndPoint theirAddress + (theirEndPoint, connId) <- + createConnectionTo transport ourEndPoint theirAddress hints + -- connAlive can be an IORef rather than an MVar because it is protected + -- by the remoteState MVar. We don't need the overhead of locking twice. + connAlive <- newIORef True + return Connection + { send = apiSend (ourEndPoint, theirEndPoint) connId connAlive + , close = apiClose (ourEndPoint, theirEndPoint) connId connAlive + } + where + params = transportParams transport + +-- | Close a connection +apiClose :: EndPointPair -> LightweightConnectionId -> IORef Bool -> IO () +apiClose (ourEndPoint, theirEndPoint) connId connAlive = + void . tryIO . asyncWhenCancelled return $ finally + (withScheduledAction ourEndPoint $ \sched -> do + modifyMVar_ (remoteState theirEndPoint) $ \st -> case st of + RemoteEndPointValid vst -> do + alive <- readIORef connAlive + if alive + then do + writeIORef connAlive False + sched theirEndPoint $ + sendOn vst [ + encodeWord32 (encodeControlHeader CloseConnection) + , encodeWord32 connId + ] + return ( RemoteEndPointValid + . (remoteOutgoing ^: (\x -> x - 1)) + $ vst + ) + else + return (RemoteEndPointValid vst) + _ -> + return st) + (closeIfUnused (ourEndPoint, theirEndPoint)) + + +-- | Send data across a connection +apiSend :: EndPointPair -- ^ Local and remote endpoint + -> LightweightConnectionId -- ^ Connection ID + -> IORef Bool -- ^ Is the connection still alive? + -> [ByteString] -- ^ Payload + -> IO (Either (TransportError SendErrorCode) ()) +apiSend (ourEndPoint, theirEndPoint) connId connAlive payload = + -- We don't need the overhead of asyncWhenCancelled here + try . mapIOException sendFailed $ withScheduledAction ourEndPoint $ \sched -> do + withMVar (remoteState theirEndPoint) $ \st -> case st of + RemoteEndPointInvalid _ -> + relyViolation (ourEndPoint, theirEndPoint) "apiSend" + RemoteEndPointInit _ _ _ -> + relyViolation (ourEndPoint, theirEndPoint) "apiSend" + RemoteEndPointValid vst -> do + alive <- readIORef connAlive + if alive + then sched theirEndPoint $ + sendOn vst (encodeWord32 connId : prependLength payload) + else throwIO $ TransportError SendClosed "Connection closed" + RemoteEndPointClosing _ _ -> do + alive <- readIORef connAlive + if alive + -- RemoteEndPointClosing is only entered by 'closeIfUnused', + -- which guarantees that there are no alive connections. + then relyViolation (ourEndPoint, theirEndPoint) "apiSend RemoteEndPointClosing" + else throwIO $ TransportError SendClosed "Connection closed" + RemoteEndPointClosed -> do + alive <- readIORef connAlive + if alive + -- This is normal. If the remote endpoint closes up while we have + -- an outgoing connection (CloseEndPoint or CloseSocket message), + -- we'll post the connection lost event but we won't update these + -- 'connAlive' IORefs. + then throwIO $ TransportError SendFailed "Remote endpoint closed" + else throwIO $ TransportError SendClosed "Connection closed" + RemoteEndPointFailed err -> do + alive <- readIORef connAlive + if alive + then throwIO $ TransportError SendFailed (show err) + else throwIO $ TransportError SendClosed "Connection closed" + where + sendFailed = TransportError SendFailed . show + +-- | Force-close the endpoint +apiCloseEndPoint :: TCPTransport -- ^ Transport + -> [Event] -- ^ Events used to report closure + -> LocalEndPoint -- ^ Local endpoint + -> IO () +apiCloseEndPoint transport evs ourEndPoint = + asyncWhenCancelled return $ do + -- Remove the reference from the transport state + removeLocalEndPoint transport ourEndPoint + -- Close the local endpoint + mOurState <- modifyMVar (localState ourEndPoint) $ \st -> + case st of + LocalEndPointValid vst -> + return (LocalEndPointClosed, Just vst) + LocalEndPointClosed -> + return (LocalEndPointClosed, Nothing) + forM_ mOurState $ \vst -> do + forM_ (vst ^. localConnections) tryCloseRemoteSocket + let qdisc = localQueue ourEndPoint + forM_ evs (qdiscEnqueue' qdisc (localAddress ourEndPoint)) + where + -- Close the remote socket and return the set of all incoming connections + tryCloseRemoteSocket :: RemoteEndPoint -> IO () + tryCloseRemoteSocket theirEndPoint = withScheduledAction ourEndPoint $ \sched -> do + -- We make an attempt to close the connection nicely + -- (by sending a CloseSocket first) + let closed = RemoteEndPointFailed . userError $ "apiCloseEndPoint" + modifyMVar_ (remoteState theirEndPoint) $ \st -> + case st of + RemoteEndPointInvalid _ -> + return st + RemoteEndPointInit resolved _ _ -> do + putMVar resolved () + return closed + RemoteEndPointValid vst -> do + -- Schedule an action to send a CloseEndPoint message and then + -- wait for the socket to actually close (meaning that this + -- end point is no longer receiving from it). + -- Since we replace the state in this MVar with 'closed', it's + -- guaranteed that no other actions will be scheduled after this + -- one. + sched theirEndPoint $ do + void $ tryIO $ sendOn vst + [ encodeWord32 (encodeControlHeader CloseEndPoint) ] + -- Release probing resources if probing. + forM_ (remoteProbing vst) id + tryShutdownSocketBoth (remoteSocket vst) + remoteSocketClosed vst + return closed + RemoteEndPointClosing resolved vst -> do + -- Release probing resources if probing. + forM_ (remoteProbing vst) id + putMVar resolved () + -- Schedule an action to wait for the socket to actually close (this + -- end point is no longer receiving from it). + -- Since we replace the state in this MVar with 'closed', it's + -- guaranteed that no other actions will be scheduled after this + -- one. + sched theirEndPoint $ do + tryShutdownSocketBoth (remoteSocket vst) + remoteSocketClosed vst + return closed + RemoteEndPointClosed -> + return st + RemoteEndPointFailed err -> + return (RemoteEndPointFailed err) + + +-------------------------------------------------------------------------------- +-- Incoming requests -- +-------------------------------------------------------------------------------- + +-- | Handle a connection request (that is, a remote endpoint that is trying to +-- establish a TCP connection with us) +-- +-- 'handleConnectionRequest' runs in the context of the transport thread, which +-- can be killed asynchronously by 'closeTransport'. We fork a separate thread +-- as soon as we have located the lcoal endpoint that the remote endpoint is +-- interested in. We cannot fork any sooner because then we have no way of +-- storing the thread ID and hence no way of killing the thread when we take +-- the transport down. We must be careful to close the socket when a (possibly +-- asynchronous, ThreadKilled) exception occurs. (If an exception escapes from +-- handleConnectionRequest the transport will be shut down.) +handleConnectionRequest :: TCPTransport -> IO () -> (N.Socket, N.SockAddr) -> IO () +handleConnectionRequest transport socketClosed (sock, sockAddr) = handle handleException $ do + when (tcpNoDelay $ transportParams transport) $ + N.setSocketOption sock N.NoDelay 1 + when (tcpKeepAlive $ transportParams transport) $ + N.setSocketOption sock N.KeepAlive 1 + forM_ (tcpUserTimeout $ transportParams transport) $ + N.setSocketOption sock N.UserTimeout + let handleVersioned = do + -- Always receive the protocol version and a handshake (content of the + -- handshake is version-dependent, but the length is always sent, + -- regardless of the version). + protocolVersion <- recvWord32 sock + handshakeLength <- recvWord32 sock + -- For now we support only version 0.0.0.0. + case protocolVersion of + 0x00000000 -> handleConnectionRequestV0 (sock, sockAddr) + _ -> do + -- Inform the peer that we want version 0x00000000 + sendMany sock [ + encodeWord32 (encodeConnectionRequestResponse ConnectionRequestUnsupportedVersion) + , encodeWord32 0x00000000 + ] + -- Clear the socket of the unsupported handshake data. + _ <- recvExact sock handshakeLength + handleVersioned + -- The handshake must complete within the optional timeout duration. + -- No socket 'recv's are to be run outside the timeout. The continuation + -- returned may 'send', but not 'recv'. + let connTimeout = transportConnectTimeout (transportParams transport) + outcome <- maybe (fmap Just) System.Timeout.timeout connTimeout handleVersioned + case outcome of + Nothing -> throwIO (userError "handleConnectionRequest: timed out") + Just act -> forM_ act id + + where + + handleException :: SomeException -> IO () + handleException ex = do + rethrowIfAsync (fromException ex) + + rethrowIfAsync :: Maybe AsyncException -> IO () + rethrowIfAsync = mapM_ throwIO + + handleConnectionRequestV0 :: (N.Socket, N.SockAddr) -> IO (Maybe (IO ())) + handleConnectionRequestV0 (sock, sockAddr) = do + -- Get the OS-determined host and port. + (numericHost, resolvedHost, actualPort) <- + resolveSockAddr sockAddr >>= + maybe (throwIO (userError "handleConnectionRequest: invalid socket address")) return + -- The peer must send our identifier and their address promptly, if a + -- timeout is set. + (ourEndPointId, theirAddress, mTheirHost) <- do + ourEndPointId <- recvWord32 sock + let maxAddressLength = tcpMaxAddressLength $ transportParams transport + mTheirAddress <- BS.concat <$> recvWithLength maxAddressLength sock + -- Sending a length = 0 address means unaddressable. + if BS.null mTheirAddress + then do + theirAddress <- randomEndPointAddress + return (ourEndPointId, theirAddress, Nothing) + else do + let theirAddress = EndPointAddress mTheirAddress + (theirHost, _, _) + <- maybe (throwIO (userError "handleConnectionRequest: peer gave malformed address")) + return + (decodeEndPointAddress theirAddress) + return (ourEndPointId, theirAddress, Just theirHost) + let checkPeerHost = tcpCheckPeerHost (transportParams transport) + continue <- case (mTheirHost, checkPeerHost) of + (Just theirHost, True) -> do + -- If the OS-determined host doesn't match the host that the peer gave us, + -- then we have no choice but to reject the connection. It's because we + -- use the EndPointAddress to key the remote end points (localConnections) + -- and we don't want to allow a peer to deny service to other peers by + -- claiming to have their host and port. + if theirHost == numericHost || theirHost == resolvedHost + then return True + else do + sendMany sock $ + encodeWord32 (encodeConnectionRequestResponse ConnectionRequestHostMismatch) + : (prependLength [BSC.pack theirHost] ++ prependLength [BSC.pack numericHost] ++ prependLength [BSC.pack resolvedHost]) + return False + _ -> return True + if continue + then do + ourEndPoint <- withMVar (transportState transport) $ \st -> case st of + TransportValid vst -> + case vst ^. localEndPointAt ourEndPointId of + Nothing -> do + sendMany sock [encodeWord32 (encodeConnectionRequestResponse ConnectionRequestInvalid)] + throwIO $ userError "handleConnectionRequest: Invalid endpoint" + Just ourEndPoint -> + return ourEndPoint + TransportClosed -> + throwIO $ userError "Transport closed" + return (Just (go ourEndPoint theirAddress)) + else return Nothing + + where + + go :: LocalEndPoint -> EndPointAddress -> IO () + go ourEndPoint theirAddress = handle handleException $ do + + resetIfBroken ourEndPoint theirAddress + (theirEndPoint, isNew) <- + findRemoteEndPoint ourEndPoint theirAddress RequestedByThem Nothing + + if not isNew + then do + void $ tryIO $ sendMany sock + [encodeWord32 (encodeConnectionRequestResponse ConnectionRequestCrossed)] + probeIfValid theirEndPoint + else do + sendLock <- newMVar Nothing + let vst = ValidRemoteEndPointState + { remoteSocket = sock + , remoteSocketClosed = socketClosed + , remoteProbing = Nothing + , remoteSendLock = sendLock + , _remoteOutgoing = 0 + , _remoteIncoming = Set.empty + , _remoteLastIncoming = 0 + , _remoteNextConnOutId = firstNonReservedLightweightConnectionId + } + sendMany sock [encodeWord32 (encodeConnectionRequestResponse ConnectionRequestAccepted)] + -- resolveInit will update the shared state, and handleIncomingMessages + -- will always ultimately clean up after it. + -- Closing up the socket is also out of our hands. It will happen + -- when handleIncomingMessages finishes. + resolveInit (ourEndPoint, theirEndPoint) (RemoteEndPointValid vst) + `finally` + handleIncomingMessages (transportParams transport) (ourEndPoint, theirEndPoint) + + probeIfValid :: RemoteEndPoint -> IO () + probeIfValid theirEndPoint = modifyMVar_ (remoteState theirEndPoint) $ + \st -> case st of + RemoteEndPointValid + vst@(ValidRemoteEndPointState { remoteProbing = Nothing }) -> do + tid <- forkIO $ do + -- send probe + let params = transportParams transport + void $ tryIO $ System.Timeout.timeout + (maybe (-1) id $ transportConnectTimeout params) $ do + sendMany (remoteSocket vst) + [encodeWord32 (encodeControlHeader ProbeSocket)] + threadDelay maxBound + -- Discard the connection if this thread is not killed (i.e. the + -- probe ack does not arrive on time). + -- + -- The thread handling incoming messages will detect the socket is + -- closed and will report the failure upwards. + tryCloseSocket (remoteSocket vst) + -- Waiting the probe ack and closing the socket is only needed in + -- platforms where TCP_USER_TIMEOUT is not available or when the + -- user does not set it. Otherwise the ack would be handled at the + -- TCP level and the the thread handling incoming messages would + -- get the error. + + return $ RemoteEndPointValid + vst { remoteProbing = Just (killThread tid) } + _ -> return st + +-- | Handle requests from a remote endpoint. +-- +-- Returns only if the remote party closes the socket or if an error occurs. +-- This runs in a thread that will never be killed. +handleIncomingMessages :: TCPParameters -> EndPointPair -> IO () +handleIncomingMessages params (ourEndPoint, theirEndPoint) = + bracket acquire release act + + where + + -- Use shared remote endpoint state to get a socket, or an appropriate + -- exception in case it's neither valid nor closing. + acquire :: IO (Either IOError N.Socket) + acquire = withMVar theirState $ \st -> case st of + RemoteEndPointInvalid _ -> + relyViolation (ourEndPoint, theirEndPoint) + "handleIncomingMessages (invalid)" + RemoteEndPointInit _ _ _ -> + relyViolation (ourEndPoint, theirEndPoint) + "handleIncomingMessages (init)" + RemoteEndPointValid ep -> + return . Right $ remoteSocket ep + RemoteEndPointClosing _ ep -> + return . Right $ remoteSocket ep + RemoteEndPointClosed -> + return . Left $ userError "handleIncomingMessages (already closed)" + RemoteEndPointFailed _ -> + return . Left $ userError "handleIncomingMessages (failed)" + + -- 'Right' is the normal case in which there still is a live socket to + -- the remote endpoint, and so 'act' was run and installed its own + -- exception handler. + release :: Either IOError N.Socket -> IO () + release (Left err) = prematureExit err + release (Right _) = return () + + act :: Either IOError N.Socket -> IO () + act (Left _) = return () + act (Right sock) = go sock `catch` prematureExit + + -- Dispatch + -- + -- If a recv throws an exception this will be caught top-level and + -- 'prematureExit' will be invoked. The same will happen if the remote + -- endpoint is put into a Closed (or Closing) state by a concurrent thread + -- (because a 'send' failed) -- the individual handlers below will throw a + -- user exception which is then caught and handled the same way as an + -- exception thrown by 'recv'. + go :: N.Socket -> IO () + go sock = do + lcid <- recvWord32 sock :: IO LightweightConnectionId + if lcid >= firstNonReservedLightweightConnectionId + then do + readMessage sock lcid + go sock + else + case decodeControlHeader lcid of + Just CreatedNewConnection -> do + recvWord32 sock >>= createdNewConnection + go sock + Just CloseConnection -> do + recvWord32 sock >>= closeConnection + go sock + Just CloseSocket -> do + didClose <- recvWord32 sock >>= closeSocket sock + unless didClose $ go sock + Just CloseEndPoint -> do + let closeRemoteEndPoint vst = do + forM_ (remoteProbing vst) id + -- close incoming connections + forM_ (Set.elems $ vst ^. remoteIncoming) $ + qdiscEnqueue' ourQueue theirAddr . ConnectionClosed . connId + -- report the endpoint as gone if we have any outgoing + -- connections + when (vst ^. remoteOutgoing > 0) $ do + let code = EventConnectionLost (remoteAddress theirEndPoint) + qdiscEnqueue' ourQueue theirAddr . ErrorEvent $ + TransportError code "The remote endpoint was closed." + removeRemoteEndPoint (ourEndPoint, theirEndPoint) + modifyMVar_ theirState $ \s -> case s of + RemoteEndPointValid vst -> do + closeRemoteEndPoint vst + return RemoteEndPointClosed + RemoteEndPointClosing resolved vst -> do + closeRemoteEndPoint vst + putMVar resolved () + return RemoteEndPointClosed + _ -> return s + Just ProbeSocket -> do + forkIO $ sendMany sock [encodeWord32 (encodeControlHeader ProbeSocketAck)] + go sock + Just ProbeSocketAck -> do + stopProbing + go sock + Nothing -> + throwIO $ userError "Invalid control request" + + -- Create a new connection + createdNewConnection :: LightweightConnectionId -> IO () + createdNewConnection lcid = do + modifyMVar_ theirState $ \st -> do + vst <- case st of + RemoteEndPointInvalid _ -> + relyViolation (ourEndPoint, theirEndPoint) + "handleIncomingMessages:createNewConnection (invalid)" + RemoteEndPointInit _ _ _ -> + relyViolation (ourEndPoint, theirEndPoint) + "handleIncomingMessages:createNewConnection (init)" + RemoteEndPointValid vst -> + return ( (remoteIncoming ^: Set.insert lcid) + $ (remoteLastIncoming ^= lcid) + vst + ) + RemoteEndPointClosing resolved vst -> do + -- If the endpoint is in closing state that means we send a + -- CloseSocket request to the remote endpoint. If the remote + -- endpoint replies that it created a new connection, it either + -- ignored our request or it sent the request before it got ours. + -- Either way, at this point we simply restore the endpoint to + -- RemoteEndPointValid + putMVar resolved () + return ( (remoteIncoming ^= Set.singleton lcid) + . (remoteLastIncoming ^= lcid) + $ vst + ) + RemoteEndPointFailed err -> + throwIO err + RemoteEndPointClosed -> + relyViolation (ourEndPoint, theirEndPoint) + "createNewConnection (closed)" + return (RemoteEndPointValid vst) + qdiscEnqueue' ourQueue theirAddr (ConnectionOpened (connId lcid) ReliableOrdered theirAddr) + + -- Close a connection + -- It is important that we verify that the connection is in fact open, + -- because otherwise we should not decrement the reference count + closeConnection :: LightweightConnectionId -> IO () + closeConnection lcid = do + modifyMVar_ theirState $ \st -> case st of + RemoteEndPointInvalid _ -> + relyViolation (ourEndPoint, theirEndPoint) "closeConnection (invalid)" + RemoteEndPointInit _ _ _ -> + relyViolation (ourEndPoint, theirEndPoint) "closeConnection (init)" + RemoteEndPointValid vst -> do + unless (Set.member lcid (vst ^. remoteIncoming)) $ + throwIO $ userError "Invalid CloseConnection" + return ( RemoteEndPointValid + . (remoteIncoming ^: Set.delete lcid) + $ vst + ) + RemoteEndPointClosing _ _ -> + -- If the remote endpoint is in Closing state, that means that are as + -- far as we are concerned there are no incoming connections. This + -- means that a CloseConnection request at this point is invalid. + throwIO $ userError "Invalid CloseConnection request" + RemoteEndPointFailed err -> + throwIO err + RemoteEndPointClosed -> + relyViolation (ourEndPoint, theirEndPoint) "closeConnection (closed)" + qdiscEnqueue' ourQueue theirAddr (ConnectionClosed (connId lcid)) + + -- Close the socket (if we don't have any outgoing connections) + closeSocket :: N.Socket -> LightweightConnectionId -> IO Bool + closeSocket sock lastReceivedId = do + mAct <- modifyMVar theirState $ \st -> do + case st of + RemoteEndPointInvalid _ -> + relyViolation (ourEndPoint, theirEndPoint) + "handleIncomingMessages:closeSocket (invalid)" + RemoteEndPointInit _ _ _ -> + relyViolation (ourEndPoint, theirEndPoint) + "handleIncomingMessages:closeSocket (init)" + RemoteEndPointValid vst -> do + -- We regard a CloseSocket message as an (optimized) way for the + -- remote endpoint to indicate that all its connections to us are + -- now properly closed + forM_ (Set.elems $ vst ^. remoteIncoming) $ + qdiscEnqueue' ourQueue theirAddr . ConnectionClosed . connId + let vst' = remoteIncoming ^= Set.empty $ vst + -- The peer sends the connection id of the last connection which + -- they accepted from us. + -- + -- If it's not the same as the id of the last connection that we + -- have made to them (assuming we haven't cycled through all + -- identifiers so fast) then they hadn't seen the request before + -- they tried to close the socket. In that case, we don't close the + -- socket. They'll see our in-flight connection request and then + -- abandon their attempt to close the socket. + -- + -- It's possible that a local connection is coming up but has not + -- yet sent CreatedNewConnection (see createConnectionTo), in + -- which case remoteOutgoing is positive, but the sent and received + -- ids do match. In this case we don't close the socket, because + -- that connection will soon sent the message and bump the lastSentId. + -- + -- Both disjuncts are needed: it's possible that remoteOutgoing is + -- 0 and the ids do not match, in case we have created and closed + -- a connection but the peer has not yet heard of it. + if vst ^. remoteOutgoing > 0 || lastReceivedId /= lastSentId vst + then + return (RemoteEndPointValid vst', Nothing) + else do + -- Release probing resources if probing. + forM_ (remoteProbing vst) id + removeRemoteEndPoint (ourEndPoint, theirEndPoint) + -- Attempt to reply (but don't insist) + act <- schedule theirEndPoint $ do + void $ tryIO $ sendOn vst' + [ encodeWord32 (encodeControlHeader CloseSocket) + , encodeWord32 (vst ^. remoteLastIncoming) + ] + return (RemoteEndPointClosed, Just act) + RemoteEndPointClosing resolved vst -> do + -- Like above, we need to check if there is a ConnectionCreated + -- message that we sent but that the remote endpoint has not yet + -- received. However, since we are in 'closing' state, the only + -- way this may happen is when we sent a ConnectionCreated, + -- ConnectionClosed, and CloseSocket message, none of which have + -- yet been received. It's sufficient to check that the peer has + -- not seen the ConnectionCreated message. In case they have seen + -- it (so that lastReceivedId == lastSendId vst) then they must + -- have seen the other messages or else they would not have sent + -- CloseSocket. + -- We leave the endpoint in closing state in that case. + if lastReceivedId /= lastSentId vst + then do + return (RemoteEndPointClosing resolved vst, Nothing) + else do + -- Release probing resources if probing. + when (vst ^. remoteOutgoing > 0) $ do + let code = EventConnectionLost (remoteAddress theirEndPoint) + let msg = "socket closed prematurely by peer" + qdiscEnqueue' ourQueue theirAddr . ErrorEvent $ TransportError code msg + forM_ (remoteProbing vst) id + removeRemoteEndPoint (ourEndPoint, theirEndPoint) + -- Nothing to do, but we want to indicate that the socket + -- really did close. + act <- schedule theirEndPoint $ return () + putMVar resolved () + return (RemoteEndPointClosed, Just act) + RemoteEndPointFailed err -> + throwIO err + RemoteEndPointClosed -> + relyViolation (ourEndPoint, theirEndPoint) + "handleIncomingMessages:closeSocket (closed)" + case mAct of + Nothing -> return False + Just act -> do + runScheduledAction (ourEndPoint, theirEndPoint) act + return True + + -- Read a message and output it on the endPoint's channel. By rights we + -- should verify that the connection ID is valid, but this is unnecessary + -- overhead + readMessage :: N.Socket -> LightweightConnectionId -> IO () + readMessage sock lcid = + recvWithLength recvLimit sock >>= + qdiscEnqueue' ourQueue theirAddr . Received (connId lcid) + + -- Stop probing a connection as a result of receiving a probe ack. + stopProbing :: IO () + stopProbing = modifyMVar_ theirState $ \st -> case st of + RemoteEndPointValid + vst@(ValidRemoteEndPointState { remoteProbing = Just stop }) -> do + stop + return $ RemoteEndPointValid vst { remoteProbing = Nothing } + _ -> return st + + -- Arguments + ourQueue = localQueue ourEndPoint + ourState = localState ourEndPoint + theirState = remoteState theirEndPoint + theirAddr = remoteAddress theirEndPoint + recvLimit = tcpMaxReceiveLength params + + -- Deal with a premature exit + prematureExit :: IOException -> IO () + prematureExit err = do + modifyMVar_ theirState $ \st -> + case st of + RemoteEndPointInvalid _ -> + relyViolation (ourEndPoint, theirEndPoint) + "handleIncomingMessages:prematureExit" + RemoteEndPointInit _ _ _ -> + relyViolation (ourEndPoint, theirEndPoint) + "handleIncomingMessages:prematureExit" + RemoteEndPointValid vst -> do + -- Release probing resources if probing. + forM_ (remoteProbing vst) id + let code = EventConnectionLost (remoteAddress theirEndPoint) + qdiscEnqueue' ourQueue theirAddr . ErrorEvent $ TransportError code (show err) + return (RemoteEndPointFailed err) + RemoteEndPointClosing resolved vst -> do + -- Release probing resources if probing. + forM_ (remoteProbing vst) id + putMVar resolved () + return (RemoteEndPointFailed err) + RemoteEndPointClosed -> + relyViolation (ourEndPoint, theirEndPoint) + "handleIncomingMessages:prematureExit" + RemoteEndPointFailed err' -> do + -- Here we post a connection-lost event, but only if the + -- local endpoint is not closed; if it's closed, the EndPointClosed + -- event will be posted without connection-lost events, and this is + -- part of the network-transport specification (there's a test + -- case for it). + modifyMVar_ ourState $ \st' -> case st' of + LocalEndPointClosed -> return st' + LocalEndPointValid _ -> do + let code = EventConnectionLost (remoteAddress theirEndPoint) + err = TransportError code (show err') + qdiscEnqueue' ourQueue theirAddr (ErrorEvent err) + return st' + return (RemoteEndPointFailed err') + + -- Construct a connection ID + connId :: LightweightConnectionId -> ConnectionId + connId = createConnectionId (remoteId theirEndPoint) + + -- The ID of the last connection _we_ created (or 0 for none) + lastSentId :: ValidRemoteEndPointState -> LightweightConnectionId + lastSentId vst = + if vst ^. remoteNextConnOutId == firstNonReservedLightweightConnectionId + then 0 + else (vst ^. remoteNextConnOutId) - 1 + +-------------------------------------------------------------------------------- +-- Uninterruptable auxiliary functions -- +-- -- +-- All these functions assume they are running in a thread which will never -- +-- be killed. +-------------------------------------------------------------------------------- + +-- | Create a connection to a remote endpoint +-- +-- If the remote endpoint is in 'RemoteEndPointClosing' state then we will +-- block until that is resolved. +-- +-- May throw a TransportError ConnectErrorCode exception. +createConnectionTo + :: TCPTransport + -> LocalEndPoint + -> EndPointAddress + -> ConnectHints + -> IO (RemoteEndPoint, LightweightConnectionId) +createConnectionTo transport ourEndPoint theirAddress hints = do + -- @timer@ is an IO action that completes when the timeout expires. + timer <- case connTimeout of + Just t -> do + mv <- newEmptyMVar + _ <- forkIO $ threadDelay t >> putMVar mv () + return $ Just $ readMVar mv + _ -> return Nothing + go timer Nothing + + where + + params = transportParams transport + connTimeout = connectTimeout hints `mplus` transportConnectTimeout params + + -- The second argument indicates the response obtained to the last + -- connection request and the remote endpoint that was used. + go timer mr = do + (theirEndPoint, isNew) <- mapIOException connectFailed + (findRemoteEndPoint ourEndPoint theirAddress RequestedByUs timer) + `finally` case mr of + Just (theirEndPoint, ConnectionRequestCrossed) -> + modifyMVar_ (remoteState theirEndPoint) $ + \rst -> case rst of + RemoteEndPointInit resolved _ _ -> do + putMVar resolved () + removeRemoteEndPoint (ourEndPoint, theirEndPoint) + return RemoteEndPointClosed + _ -> return rst + _ -> return () + if isNew + then do + mr' <- handle (absorbAllExceptions Nothing) $ + setupRemoteEndPoint transport (ourEndPoint, theirEndPoint) connTimeout + go timer (fmap ((,) theirEndPoint) mr') + else do + -- 'findRemoteEndPoint' will have increased 'remoteOutgoing' + mapIOException connectFailed $ do + act <- modifyMVar (remoteState theirEndPoint) $ \st -> case st of + RemoteEndPointValid vst -> do + let connId = vst ^. remoteNextConnOutId + act <- schedule theirEndPoint $ do + sendOn vst [ + encodeWord32 (encodeControlHeader CreatedNewConnection) + , encodeWord32 connId + ] + return connId + return ( RemoteEndPointValid + $ remoteNextConnOutId ^= connId + 1 + $ vst + , act + ) + -- Error cases + RemoteEndPointInvalid err -> + throwIO err + RemoteEndPointFailed err -> + throwIO err + -- Algorithmic errors + _ -> + relyViolation (ourEndPoint, theirEndPoint) "createConnectionTo" + -- TODO: deal with exception case? + connId <- runScheduledAction (ourEndPoint, theirEndPoint) act + return (theirEndPoint, connId) + + + connectFailed :: IOException -> TransportError ConnectErrorCode + connectFailed = TransportError ConnectFailed . show + + absorbAllExceptions :: a -> SomeException -> IO a + absorbAllExceptions a _ex = + return a + +-- | Set up a remote endpoint +setupRemoteEndPoint + :: TCPTransport + -> EndPointPair + -> Maybe Int + -> IO (Maybe ConnectionRequestResponse) +setupRemoteEndPoint transport (ourEndPoint, theirEndPoint) connTimeout = do + let mOurAddress = const ourAddress <$> transportAddrInfo transport + result <- socketToEndPoint mOurAddress + theirAddress + (tcpReuseClientAddr params) + (tcpNoDelay params) + (tcpKeepAlive params) + (tcpUserTimeout params) + connTimeout + didAccept <- case result of + -- Since a socket was created, we are now responsible for closing it. + -- + -- In case the connection was accepted, we have some work to do. + -- We'll remember how to wait for the socket to close + -- (readMVar socketClosedVar), and we'll take care of closing it up + -- once handleIncomingMessages has finished. + Right (socketClosedVar, sock, ConnectionRequestAccepted) -> do + sendLock <- newMVar Nothing + let vst = ValidRemoteEndPointState + { remoteSocket = sock + , remoteSocketClosed = readMVar socketClosedVar + , remoteProbing = Nothing + , remoteSendLock = sendLock + , _remoteOutgoing = 0 + , _remoteIncoming = Set.empty + , _remoteLastIncoming = 0 + , _remoteNextConnOutId = firstNonReservedLightweightConnectionId + } + resolveInit (ourEndPoint, theirEndPoint) (RemoteEndPointValid vst) + return (Just (socketClosedVar, sock)) + Right (socketClosedVar, sock, ConnectionRequestUnsupportedVersion) -> do + -- If the peer doesn't support V0 then there's nothing we can do, for + -- it's the only version we support. + let err = connectFailed "setupRemoteEndPoint: unsupported version" + resolveInit (ourEndPoint, theirEndPoint) (RemoteEndPointInvalid err) + tryCloseSocket sock `finally` putMVar socketClosedVar () + return Nothing + Right (socketClosedVar, sock, ConnectionRequestInvalid) -> do + let err = invalidAddress "setupRemoteEndPoint: Invalid endpoint" + resolveInit (ourEndPoint, theirEndPoint) (RemoteEndPointInvalid err) + tryCloseSocket sock `finally` putMVar socketClosedVar () + return Nothing + Right (socketClosedVar, sock, ConnectionRequestCrossed) -> do + withMVar (remoteState theirEndPoint) $ \st -> case st of + RemoteEndPointInit _ crossed _ -> + putMVar crossed () + RemoteEndPointFailed ex -> + throwIO ex + _ -> + relyViolation (ourEndPoint, theirEndPoint) "setupRemoteEndPoint: Crossed" + tryCloseSocket sock `finally` putMVar socketClosedVar () + return Nothing + Right (socketClosedVar, sock, ConnectionRequestHostMismatch) -> do + let handler :: SomeException -> IO (TransportError ConnectErrorCode) + handler err = return (TransportError ConnectFailed (show err)) + err <- handle handler $ do + claimedHost <- recvWithLength (tcpMaxReceiveLength params) sock + actualNumericHost <- recvWithLength (tcpMaxReceiveLength params) sock + actualResolvedHost <- recvWithLength (tcpMaxReceiveLength params) sock + let reason = concat [ + "setupRemoteEndPoint: Host mismatch" + , ". Claimed: " + , BSC.unpack (BS.concat claimedHost) + , "; Numeric: " + , BSC.unpack (BS.concat actualNumericHost) + , "; Resolved: " + , BSC.unpack (BS.concat actualResolvedHost) + ] + return (TransportError ConnectFailed reason) + resolveInit (ourEndPoint, theirEndPoint) (RemoteEndPointInvalid err) + tryCloseSocket sock `finally` putMVar socketClosedVar () + return Nothing + Left err -> do + resolveInit (ourEndPoint, theirEndPoint) (RemoteEndPointInvalid err) + return Nothing + + -- We handle incoming messages in a separate thread, and are careful to + -- always close the socket once that thread is finished. + forM_ didAccept $ \(socketClosed, sock) -> void $ forkIO $ + handleIncomingMessages params (ourEndPoint, theirEndPoint) + `finally` + (tryCloseSocket sock `finally` putMVar socketClosed ()) + return $ either (const Nothing) (Just . (\(_,_,x) -> x)) result + where + params = transportParams transport + ourAddress = localAddress ourEndPoint + theirAddress = remoteAddress theirEndPoint + invalidAddress = TransportError ConnectNotFound + connectFailed = TransportError ConnectFailed + +-- | Send a CloseSocket request if the remote endpoint is unused +closeIfUnused :: EndPointPair -> IO () +closeIfUnused (ourEndPoint, theirEndPoint) = do + mAct <- modifyMVar (remoteState theirEndPoint) $ \st -> case st of + RemoteEndPointValid vst -> + if vst ^. remoteOutgoing == 0 && Set.null (vst ^. remoteIncoming) + then do + resolved <- newEmptyMVar + act <- schedule theirEndPoint $ + sendOn vst [ encodeWord32 (encodeControlHeader CloseSocket) + , encodeWord32 (vst ^. remoteLastIncoming) + ] + return (RemoteEndPointClosing resolved vst, Just act) + else + return (RemoteEndPointValid vst, Nothing) + _ -> + return (st, Nothing) + forM_ mAct $ runScheduledAction (ourEndPoint, theirEndPoint) + +-- | Reset a remote endpoint if it is in Invalid mode +-- +-- If the remote endpoint is currently in broken state, and +-- +-- - a user calls the API function 'connect', or and the remote endpoint is +-- - an inbound connection request comes in from this remote address +-- +-- we remove the remote endpoint first. +-- +-- Throws a TransportError ConnectFailed exception if the local endpoint is +-- closed. +resetIfBroken :: LocalEndPoint -> EndPointAddress -> IO () +resetIfBroken ourEndPoint theirAddress = do + mTheirEndPoint <- withMVar (localState ourEndPoint) $ \st -> case st of + LocalEndPointValid vst -> + return (vst ^. localConnectionTo theirAddress) + LocalEndPointClosed -> + throwIO $ TransportError ConnectFailed "Endpoint closed" + forM_ mTheirEndPoint $ \theirEndPoint -> + withMVar (remoteState theirEndPoint) $ \st -> case st of + RemoteEndPointInvalid _ -> + removeRemoteEndPoint (ourEndPoint, theirEndPoint) + RemoteEndPointFailed _ -> + removeRemoteEndPoint (ourEndPoint, theirEndPoint) + _ -> + return () + +-- | Special case of 'apiConnect': connect an endpoint to itself +-- +-- May throw a TransportError ConnectErrorCode (if the local endpoint is closed) +connectToSelf :: LocalEndPoint + -> IO Connection +connectToSelf ourEndPoint = do + connAlive <- newIORef True -- Protected by the local endpoint lock + lconnId <- mapIOException connectFailed $ getLocalNextConnOutId ourEndPoint + let connId = createConnectionId heavyweightSelfConnectionId lconnId + qdiscEnqueue' ourQueue ourAddress $ + ConnectionOpened connId ReliableOrdered (localAddress ourEndPoint) + return Connection + { send = selfSend connAlive connId + , close = selfClose connAlive connId + } + where + selfSend :: IORef Bool + -> ConnectionId + -> [ByteString] + -> IO (Either (TransportError SendErrorCode) ()) + selfSend connAlive connId msg = + try . withMVar ourState $ \st -> case st of + LocalEndPointValid _ -> do + alive <- readIORef connAlive + if alive + then seq (foldr seq () msg) + qdiscEnqueue' ourQueue ourAddress (Received connId msg) + else throwIO $ TransportError SendClosed "Connection closed" + LocalEndPointClosed -> + throwIO $ TransportError SendFailed "Endpoint closed" + + selfClose :: IORef Bool -> ConnectionId -> IO () + selfClose connAlive connId = + withMVar ourState $ \st -> case st of + LocalEndPointValid _ -> do + alive <- readIORef connAlive + when alive $ do + qdiscEnqueue' ourQueue ourAddress (ConnectionClosed connId) + writeIORef connAlive False + LocalEndPointClosed -> + return () + + ourQueue = localQueue ourEndPoint + ourState = localState ourEndPoint + connectFailed = TransportError ConnectFailed . show + ourAddress = localAddress ourEndPoint + +-- | Resolve an endpoint currently in 'Init' state +resolveInit :: EndPointPair -> RemoteState -> IO () +resolveInit (ourEndPoint, theirEndPoint) newState = + modifyMVar_ (remoteState theirEndPoint) $ \st -> case st of + RemoteEndPointInit resolved crossed _ -> do + putMVar resolved () + -- Unblock the reader (if any) if the ConnectionRequestCrossed + -- message did not come within the connection timeout. + tryPutMVar crossed () + case newState of + RemoteEndPointClosed -> + removeRemoteEndPoint (ourEndPoint, theirEndPoint) + _ -> + return () + return newState + RemoteEndPointFailed ex -> + throwIO ex + _ -> + relyViolation (ourEndPoint, theirEndPoint) "resolveInit" + +-- | Get the next outgoing self-connection ID +-- +-- Throws an IO exception when the endpoint is closed. +getLocalNextConnOutId :: LocalEndPoint -> IO LightweightConnectionId +getLocalNextConnOutId ourEndpoint = + modifyMVar (localState ourEndpoint) $ \st -> case st of + LocalEndPointValid vst -> do + let connId = vst ^. localNextConnOutId + return ( LocalEndPointValid + . (localNextConnOutId ^= connId + 1) + $ vst + , connId) + LocalEndPointClosed -> + throwIO $ userError "Local endpoint closed" + +-- | Create a new local endpoint +-- +-- May throw a TransportError NewEndPointErrorCode exception if the transport +-- is closed. +createLocalEndPoint :: TCPTransport + -> QDisc Event + -> IO LocalEndPoint +createLocalEndPoint transport qdisc = do + state <- newMVar . LocalEndPointValid $ ValidLocalEndPointState + { _localNextConnOutId = firstNonReservedLightweightConnectionId + , _localConnections = Map.empty + , _nextConnInId = firstNonReservedHeavyweightConnectionId + } + modifyMVar (transportState transport) $ \st -> case st of + TransportValid vst -> do + let ix = vst ^. nextEndPointId + addr <- case transportAddrInfo transport of + Nothing -> randomEndPointAddress + Just addrInfo -> return $ + encodeEndPointAddress (transportHost addrInfo) + (transportPort addrInfo) + ix + let localEndPoint = LocalEndPoint { localAddress = addr + , localEndPointId = ix + , localQueue = qdisc + , localState = state + } + return ( TransportValid + . (localEndPointAt ix ^= Just localEndPoint) + . (nextEndPointId ^= ix + 1) + $ vst + , localEndPoint + ) + TransportClosed -> + throwIO (TransportError NewEndPointFailed "Transport closed") + + +-- | Remove reference to a remote endpoint from a local endpoint +-- +-- If the local endpoint is closed, do nothing +removeRemoteEndPoint :: EndPointPair -> IO () +removeRemoteEndPoint (ourEndPoint, theirEndPoint) = + modifyMVar_ ourState $ \st -> case st of + LocalEndPointValid vst -> + case vst ^. localConnectionTo theirAddress of + Nothing -> + return st + Just remoteEndPoint' -> + if remoteId remoteEndPoint' == remoteId theirEndPoint + then return + ( LocalEndPointValid + . (localConnectionTo (remoteAddress theirEndPoint) ^= Nothing) + $ vst + ) + else return st + LocalEndPointClosed -> + return LocalEndPointClosed + where + ourState = localState ourEndPoint + theirAddress = remoteAddress theirEndPoint + +-- | Remove reference to a local endpoint from the transport state +-- +-- Does nothing if the transport is closed +removeLocalEndPoint :: TCPTransport -> LocalEndPoint -> IO () +removeLocalEndPoint transport ourEndPoint = + modifyMVar_ (transportState transport) $ \st -> case st of + TransportValid vst -> + return ( TransportValid + . (localEndPointAt (localEndPointId ourEndPoint) ^= Nothing) + $ vst + ) + TransportClosed -> + return TransportClosed + +-- | Find a remote endpoint. If the remote endpoint does not yet exist we +-- create it in Init state. Returns if the endpoint was new, or 'Nothing' if +-- it times out. +findRemoteEndPoint + :: LocalEndPoint + -> EndPointAddress + -> RequestedBy + -> Maybe (IO ()) -- ^ an action which completes when the time is up + -> IO (RemoteEndPoint, Bool) +findRemoteEndPoint ourEndPoint theirAddress findOrigin mtimer = go + where + go = do + (theirEndPoint, isNew) <- modifyMVar ourState $ \st -> case st of + LocalEndPointValid vst -> case vst ^. localConnectionTo theirAddress of + Just theirEndPoint -> + return (st, (theirEndPoint, False)) + Nothing -> do + resolved <- newEmptyMVar + crossed <- newEmptyMVar + theirState <- newMVar (RemoteEndPointInit resolved crossed findOrigin) + scheduled <- newChan + let theirEndPoint = RemoteEndPoint + { remoteAddress = theirAddress + , remoteState = theirState + , remoteId = vst ^. nextConnInId + , remoteScheduled = scheduled + } + return ( LocalEndPointValid + . (localConnectionTo theirAddress ^= Just theirEndPoint) + . (nextConnInId ^: (+ 1)) + $ vst + , (theirEndPoint, True) + ) + LocalEndPointClosed -> + throwIO $ userError "Local endpoint closed" + + if isNew + then + return (theirEndPoint, True) + else do + let theirState = remoteState theirEndPoint + snapshot <- modifyMVar theirState $ \st -> case st of + RemoteEndPointValid vst -> + case findOrigin of + RequestedByUs -> do + let st' = RemoteEndPointValid + . (remoteOutgoing ^: (+ 1)) + $ vst + return (st', st') + RequestedByThem -> + return (st, st) + _ -> + return (st, st) + -- The snapshot may no longer be up to date at this point, but if we + -- increased the refcount then it can only either be Valid or Failed + -- (after an explicit call to 'closeEndPoint' or 'closeTransport') + case snapshot of + RemoteEndPointInvalid err -> + throwIO err + RemoteEndPointInit resolved crossed initOrigin -> + case (findOrigin, initOrigin) of + (RequestedByUs, RequestedByUs) -> + readMVarTimeout mtimer resolved >> go + (RequestedByUs, RequestedByThem) -> + readMVarTimeout mtimer resolved >> go + (RequestedByThem, RequestedByUs) -> + if ourAddress > theirAddress + then do + -- Wait for the Crossed message and recheck the state + -- of the remote endpoint after this (it may well be + -- invalid already in case of a timeout). + tryReadMVar crossed >>= \case + Nothing -> readMVarTimeout mtimer crossed >> go + _ -> return (theirEndPoint, True) + else + return (theirEndPoint, False) + (RequestedByThem, RequestedByThem) -> + throwIO $ userError "Already connected" + RemoteEndPointValid _ -> + -- We assume that the request crossed if we find the endpoint in + -- Valid state. It is possible that this is really an invalid + -- request, but only in the case of a broken client (we don't + -- maintain enough history to be able to tell the difference). + return (theirEndPoint, False) + RemoteEndPointClosing resolved _ -> + readMVarTimeout mtimer resolved >> go + RemoteEndPointClosed -> + go + RemoteEndPointFailed err -> + throwIO err + + ourState = localState ourEndPoint + ourAddress = localAddress ourEndPoint + + -- | Like 'readMVar' but it throws an exception if the timer expires. + readMVarTimeout Nothing mv = readMVar mv + readMVarTimeout (Just timer) mv = do + let connectTimedout = TransportError ConnectTimeout "Timed out" + tid <- myThreadId + bracket (forkIO $ timer >> throwTo tid connectTimedout) killThread $ + const $ readMVar mv + +-- | Send a payload over a heavyweight connection (thread safe) +-- +-- The socket cannot be used for sending after the non-atomic 'sendMany' +-- is interrupted - otherwise, the other side may get the msg corrupted. +-- +-- There are two types of possible exceptions here: +-- 1) Outer asynchronous exceptions (like 'ProcessLinkException'). +-- 2) Synchronous exceptions (inner or outer). +-- On a synchronous exception the remote endpoint is failed (see 'runScheduledAction', +-- for example) and its socket is not supposed to be used again. +-- +-- With 'async' the code is run in a new thread which is not-targeted (and +-- thus, not interrupted) by the 1st type of exceptions. With 'remoteSendLock' +-- we protect the socket usage by the concurrent threads, as well as prevent +-- that usage after SomeException. +sendOn :: ValidRemoteEndPointState -> [ByteString] -> IO () +sendOn vst bs = (wait =<<) $ async $ + mask $ \restore -> do + let lock = remoteSendLock vst + maybeException <- takeMVar lock + when (isNothing maybeException) $ + restore (sendMany (remoteSocket vst) bs) `catch` \ex -> do + putMVar lock (Just ex) + throwIO ex + putMVar lock maybeException + forM_ maybeException $ \e -> + throwIO $ userError $ "sendOn failed earlier with: " ++ show e + +-------------------------------------------------------------------------------- +-- Scheduling actions -- +-------------------------------------------------------------------------------- + +-- | See 'schedule'/'runScheduledAction' +type Action a = MVar (Either SomeException a) + +-- | Schedule an action to be executed (see also 'runScheduledAction') +schedule :: RemoteEndPoint -> IO a -> IO (Action a) +schedule theirEndPoint act = do + mvar <- newEmptyMVar + writeChan (remoteScheduled theirEndPoint) $ + catch (act >>= putMVar mvar . Right) (putMVar mvar . Left) + return mvar + +-- | Run a scheduled action. Every call to 'schedule' should be paired with a +-- call to 'runScheduledAction' so that every scheduled action is run. Note +-- however that the there is no guarantee that in +-- +-- > do act <- schedule p +-- > runScheduledAction +-- +-- 'runScheduledAction' will run @p@ (it might run some other scheduled action). +-- However, it will then wait until @p@ is executed (by this call to +-- 'runScheduledAction' or by another). +runScheduledAction :: EndPointPair -> Action a -> IO a +runScheduledAction (ourEndPoint, theirEndPoint) mvar = do + join $ readChan (remoteScheduled theirEndPoint) + ma <- readMVar mvar + case ma of + Right a -> return a + Left e -> do + forM_ (fromException e) $ \ioe -> + modifyMVar_ (remoteState theirEndPoint) $ \st -> + case st of + RemoteEndPointValid vst -> handleIOException ioe vst + _ -> return (RemoteEndPointFailed ioe) + throwIO e + where + handleIOException :: IOException + -> ValidRemoteEndPointState + -> IO RemoteState + handleIOException ex vst = do + -- Release probing resources if probing. + forM_ (remoteProbing vst) id + -- Must shut down the socket here, so that the other end will realize + -- we lost the connection + tryShutdownSocketBoth (remoteSocket vst) + -- Eventually, handleIncomingMessages will fail while trying to + -- receive, and ultimately enqueue the 'EventConnectionLost'. + return (RemoteEndPointFailed ex) + +-- | Use 'schedule' action 'runScheduled' action in a safe way, it's assumed that +-- callback is used only once, otherwise guarantees of runScheduledAction are not +-- respected. +withScheduledAction :: LocalEndPoint -> ((RemoteEndPoint -> IO a -> IO ()) -> IO ()) -> IO () +withScheduledAction ourEndPoint f = + bracket (newIORef Nothing) + (traverse (\(tp, a) -> runScheduledAction (ourEndPoint, tp) a) <=< readIORef) + (\ref -> f (\rp g -> mask_ $ schedule rp g >>= \x -> writeIORef ref (Just (rp,x)) )) + +-------------------------------------------------------------------------------- +-- "Stateless" (MVar free) functions -- +-------------------------------------------------------------------------------- + +-- | Establish a connection to a remote endpoint +-- +-- Maybe throw a TransportError +-- +-- If a socket is created and returned (Right is given) then the caller is +-- responsible for eventually closing the socket and filling the MVar (which +-- is empty). The MVar must be filled immediately after, and never before, +-- the socket is closed. +socketToEndPoint :: Maybe EndPointAddress -- ^ Our address + -> EndPointAddress -- ^ Their address + -> Bool -- ^ Use SO_REUSEADDR? + -> Bool -- ^ Use TCP_NODELAY + -> Bool -- ^ Use TCP_KEEPALIVE + -> Maybe Int -- ^ Maybe TCP_USER_TIMEOUT + -> Maybe Int -- ^ Timeout for connect + -> IO (Either (TransportError ConnectErrorCode) + (MVar (), N.Socket, ConnectionRequestResponse)) +socketToEndPoint mOurAddress theirAddress reuseAddr noDelay keepAlive + mUserTimeout timeout = + try $ do + (host, port, theirEndPointId) <- case decodeEndPointAddress theirAddress of + Nothing -> throwIO (failed . userError $ "Could not parse") + Just dec -> return dec + addr:_ <- mapIOException invalidAddress $ + N.getAddrInfo Nothing (Just host) (Just port) + bracketOnError (createSocket addr) tryCloseSocket $ \sock -> do + when reuseAddr $ + mapIOException failed $ N.setSocketOption sock N.ReuseAddr 1 + when noDelay $ + mapIOException failed $ N.setSocketOption sock N.NoDelay 1 + when keepAlive $ + mapIOException failed $ N.setSocketOption sock N.KeepAlive 1 + forM_ mUserTimeout $ + mapIOException failed . N.setSocketOption sock N.UserTimeout + response <- timeoutMaybe timeout timeoutError $ do + mapIOException invalidAddress $ + N.connect sock (N.addrAddress addr) + mapIOException failed $ do + case mOurAddress of + Just (EndPointAddress ourAddress) -> + sendMany sock $ + encodeWord32 currentProtocolVersion + : prependLength (encodeWord32 theirEndPointId : prependLength [ourAddress]) + Nothing -> + sendMany sock $ + encodeWord32 currentProtocolVersion + : prependLength ([encodeWord32 theirEndPointId, encodeWord32 0]) + recvWord32 sock + case decodeConnectionRequestResponse response of + Nothing -> throwIO (failed . userError $ "Unexpected response") + Just r -> do + socketClosedVar <- newEmptyMVar + return (socketClosedVar, sock, r) + where + createSocket :: N.AddrInfo -> IO N.Socket + createSocket addr = mapIOException insufficientResources $ + N.socket (N.addrFamily addr) N.Stream N.defaultProtocol + + invalidAddress = TransportError ConnectNotFound . show + insufficientResources = TransportError ConnectInsufficientResources . show + failed = TransportError ConnectFailed . show + timeoutError = TransportError ConnectTimeout "Timed out" + +-- | Construct a ConnectionId +createConnectionId :: HeavyweightConnectionId + -> LightweightConnectionId + -> ConnectionId +createConnectionId hcid lcid = + (fromIntegral hcid `shiftL` 32) .|. fromIntegral lcid + +-------------------------------------------------------------------------------- +-- Functions from TransportInternals -- +-------------------------------------------------------------------------------- + +-- Find a socket between two endpoints +-- +-- Throws an IO exception if the socket could not be found. +internalSocketBetween :: TCPTransport -- ^ Transport + -> EndPointAddress -- ^ Local endpoint + -> EndPointAddress -- ^ Remote endpoint + -> IO N.Socket +internalSocketBetween transport ourAddress theirAddress = do + ourEndPointId <- case decodeEndPointAddress ourAddress of + Just (_, _, eid) -> return eid + _ -> throwIO $ userError "Malformed local EndPointAddress" + ourEndPoint <- withMVar (transportState transport) $ \st -> case st of + TransportClosed -> + throwIO $ userError "Transport closed" + TransportValid vst -> + case vst ^. localEndPointAt ourEndPointId of + Nothing -> throwIO $ userError "Local endpoint not found" + Just ep -> return ep + theirEndPoint <- withMVar (localState ourEndPoint) $ \st -> case st of + LocalEndPointClosed -> + throwIO $ userError "Local endpoint closed" + LocalEndPointValid vst -> + case vst ^. localConnectionTo theirAddress of + Nothing -> throwIO $ userError "Remote endpoint not found" + Just ep -> return ep + withMVar (remoteState theirEndPoint) $ \st -> case st of + RemoteEndPointInit _ _ _ -> + throwIO $ userError "Remote endpoint not yet initialized" + RemoteEndPointValid vst -> + return $ remoteSocket vst + RemoteEndPointClosing _ vst -> + return $ remoteSocket vst + RemoteEndPointClosed -> + throwIO $ userError "Remote endpoint closed" + RemoteEndPointInvalid err -> + throwIO err + RemoteEndPointFailed err -> + throwIO err + where + +-------------------------------------------------------------------------------- +-- Constants -- +-------------------------------------------------------------------------------- + +-- | We reserve a bunch of connection IDs for control messages +firstNonReservedLightweightConnectionId :: LightweightConnectionId +firstNonReservedLightweightConnectionId = 1024 + +-- | Self-connection +heavyweightSelfConnectionId :: HeavyweightConnectionId +heavyweightSelfConnectionId = 0 + +-- | We reserve some connection IDs for special heavyweight connections +firstNonReservedHeavyweightConnectionId :: HeavyweightConnectionId +firstNonReservedHeavyweightConnectionId = 1 + +-------------------------------------------------------------------------------- +-- Accessor definitions -- +-------------------------------------------------------------------------------- + +localEndPoints :: Accessor ValidTransportState (Map EndPointId LocalEndPoint) +localEndPoints = accessor _localEndPoints (\es st -> st { _localEndPoints = es }) + +nextEndPointId :: Accessor ValidTransportState EndPointId +nextEndPointId = accessor _nextEndPointId (\eid st -> st { _nextEndPointId = eid }) + +localNextConnOutId :: Accessor ValidLocalEndPointState LightweightConnectionId +localNextConnOutId = accessor _localNextConnOutId (\cix st -> st { _localNextConnOutId = cix }) + +localConnections :: Accessor ValidLocalEndPointState (Map EndPointAddress RemoteEndPoint) +localConnections = accessor _localConnections (\es st -> st { _localConnections = es }) + +nextConnInId :: Accessor ValidLocalEndPointState HeavyweightConnectionId +nextConnInId = accessor _nextConnInId (\rid st -> st { _nextConnInId = rid }) + +remoteOutgoing :: Accessor ValidRemoteEndPointState Int +remoteOutgoing = accessor _remoteOutgoing (\cs conn -> conn { _remoteOutgoing = cs }) + +remoteIncoming :: Accessor ValidRemoteEndPointState (Set LightweightConnectionId) +remoteIncoming = accessor _remoteIncoming (\cs conn -> conn { _remoteIncoming = cs }) + +remoteLastIncoming :: Accessor ValidRemoteEndPointState LightweightConnectionId +remoteLastIncoming = accessor _remoteLastIncoming (\lcid st -> st { _remoteLastIncoming = lcid }) + +remoteNextConnOutId :: Accessor ValidRemoteEndPointState LightweightConnectionId +remoteNextConnOutId = accessor _remoteNextConnOutId (\cix st -> st { _remoteNextConnOutId = cix }) + +localEndPointAt :: EndPointId -> Accessor ValidTransportState (Maybe LocalEndPoint) +localEndPointAt addr = localEndPoints >>> DAC.mapMaybe addr + +localConnectionTo :: EndPointAddress -> Accessor ValidLocalEndPointState (Maybe RemoteEndPoint) +localConnectionTo addr = localConnections >>> DAC.mapMaybe addr + +------------------------------------------------------------------------------- +-- Debugging -- +------------------------------------------------------------------------------- + +relyViolation :: EndPointPair -> String -> IO a +relyViolation (ourEndPoint, theirEndPoint) str = do + elog (ourEndPoint, theirEndPoint) (str ++ " RELY violation") + fail (str ++ " RELY violation") + +elog :: EndPointPair -> String -> IO () +elog (ourEndPoint, theirEndPoint) msg = do + tid <- myThreadId + putStrLn $ show (localAddress ourEndPoint) + ++ "/" ++ show (remoteAddress theirEndPoint) + ++ "(" ++ show (remoteId theirEndPoint) ++ ")" + ++ "/" ++ show tid + ++ ": " ++ msg diff --git a/packages/network-transport-tcp/src/Network/Transport/TCP/Internal.hs b/packages/network-transport-tcp/src/Network/Transport/TCP/Internal.hs new file mode 100644 index 00000000..d3213fdf --- /dev/null +++ b/packages/network-transport-tcp/src/Network/Transport/TCP/Internal.hs @@ -0,0 +1,363 @@ +{-# LANGUAGE CPP #-} +-- | Utility functions for TCP sockets +module Network.Transport.TCP.Internal + ( ControlHeader(..) + , encodeControlHeader + , decodeControlHeader + , ConnectionRequestResponse(..) + , encodeConnectionRequestResponse + , decodeConnectionRequestResponse + , forkServer + , recvWithLength + , recvExact + , recvWord32 + , encodeWord32 + , tryCloseSocket + , tryShutdownSocketBoth + , resolveSockAddr + , EndPointId + , encodeEndPointAddress + , decodeEndPointAddress + , randomEndPointAddress + , ProtocolVersion + , currentProtocolVersion + ) where + +import Network.Transport.Internal + ( decodeWord32 + , encodeWord32 + , void + , tryIO + , forkIOWithUnmask + ) + +import Network.Transport ( EndPointAddress(..) ) + +#ifdef USE_MOCK_NETWORK +import qualified Network.Transport.TCP.Mock.Socket as N +#else +import qualified Network.Socket as N +#endif + ( HostName + , NameInfoFlag(NI_NUMERICHOST) + , ServiceName + , Socket + , SocketType(Stream) + , SocketOption(ReuseAddr) + , getAddrInfo + , defaultHints + , socket + , bind + , listen + , addrFamily + , addrAddress + , defaultProtocol + , setSocketOption + , accept + , close + , socketPort + , shutdown + , ShutdownCmd(ShutdownBoth) + , SockAddr(..) + , getNameInfo + ) + +#ifdef USE_MOCK_NETWORK +import qualified Network.Transport.TCP.Mock.Socket.ByteString as NBS (recv) +#else +import qualified Network.Socket.ByteString as NBS (recv) +#endif + +import Data.Word (Word32) + +import Control.Monad (forever, when) +import Control.Exception (SomeException, catch, bracketOnError, throwIO, mask_) +import Control.Concurrent (ThreadId, forkIO) +import Control.Concurrent.MVar + ( MVar + , newEmptyMVar + , putMVar + , readMVar + ) +import Control.Exception + ( mask + , finally + ) + +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS (length, concat, null) +import Data.ByteString.Lazy.Internal (smallChunkSize) +import qualified Data.ByteString.Char8 as BSC (unpack, pack) +import qualified Data.UUID as UUID +import qualified Data.UUID.V4 as UUID + +-- | Local identifier for an endpoint within this transport +type EndPointId = Word32 + +-- | Identifies the version of the network-transport-tcp protocol. +-- It's the first piece of data sent when a new heavyweight connection is +-- established. +type ProtocolVersion = Word32 + +currentProtocolVersion :: ProtocolVersion +currentProtocolVersion = 0x00000000 + +-- | Control headers +data ControlHeader = + -- | Tell the remote endpoint that we created a new connection + CreatedNewConnection + -- | Tell the remote endpoint we will no longer be using a connection + | CloseConnection + -- | Request to close the connection (see module description) + | CloseSocket + -- | Sent by an endpoint when it is closed. + | CloseEndPoint + -- | Message sent to probe a socket + | ProbeSocket + -- | Acknowledgement of the ProbeSocket message + | ProbeSocketAck + deriving (Show) + +decodeControlHeader :: Word32 -> Maybe ControlHeader +decodeControlHeader w32 = case w32 of + 0 -> Just CreatedNewConnection + 1 -> Just CloseConnection + 2 -> Just CloseSocket + 3 -> Just CloseEndPoint + 4 -> Just ProbeSocket + 5 -> Just ProbeSocketAck + _ -> Nothing + +encodeControlHeader :: ControlHeader -> Word32 +encodeControlHeader ch = case ch of + CreatedNewConnection -> 0 + CloseConnection -> 1 + CloseSocket -> 2 + CloseEndPoint -> 3 + ProbeSocket -> 4 + ProbeSocketAck -> 5 + +-- | Response sent by /B/ to /A/ when /A/ tries to connect +data ConnectionRequestResponse = + -- | /B/ does not support the protocol version requested by /A/. + ConnectionRequestUnsupportedVersion + -- | /B/ accepts the connection + | ConnectionRequestAccepted + -- | /A/ requested an invalid endpoint + | ConnectionRequestInvalid + -- | /A/s request crossed with a request from /B/ (see protocols) + | ConnectionRequestCrossed + -- | /A/ gave an incorrect host (did not match the host that /B/ observed). + | ConnectionRequestHostMismatch + deriving (Show) + +decodeConnectionRequestResponse :: Word32 -> Maybe ConnectionRequestResponse +decodeConnectionRequestResponse w32 = case w32 of + 0xFFFFFFFF -> Just ConnectionRequestUnsupportedVersion + 0x00000000 -> Just ConnectionRequestAccepted + 0x00000001 -> Just ConnectionRequestInvalid + 0x00000002 -> Just ConnectionRequestCrossed + 0x00000003 -> Just ConnectionRequestHostMismatch + _ -> Nothing + +encodeConnectionRequestResponse :: ConnectionRequestResponse -> Word32 +encodeConnectionRequestResponse crr = case crr of + ConnectionRequestUnsupportedVersion -> 0xFFFFFFFF + ConnectionRequestAccepted -> 0x00000000 + ConnectionRequestInvalid -> 0x00000001 + ConnectionRequestCrossed -> 0x00000002 + ConnectionRequestHostMismatch -> 0x00000003 + +-- | Generate an EndPointAddress which does not encode a host/port/endpointid. +-- Such addresses are used for unreachable endpoints, and for ephemeral +-- addresses when such endpoints establish new heavyweight connections. +randomEndPointAddress :: IO EndPointAddress +randomEndPointAddress = do + uuid <- UUID.nextRandom + return $ EndPointAddress (UUID.toASCIIBytes uuid) + +-- | Start a server at the specified address. +-- +-- This sets up a server socket for the specified host and port. Exceptions +-- thrown during setup are not caught. +-- +-- Once the socket is created we spawn a new thread which repeatedly accepts +-- incoming connections and executes the given request handler in another +-- thread. If any exception occurs the accepting thread terminates and calls +-- the terminationHandler. Threads spawned for previous accepted connections +-- are not killed. +-- This exception may occur because of a call to 'N.accept', or because the +-- thread was explicitly killed. +-- +-- The request handler is not responsible for closing the socket. It will be +-- closed once that handler returns. Take care to ensure that the socket is not +-- used after the handler returns, or you will get undefined behavior +-- (the file descriptor may be re-used). +-- +-- The return value includes the port was bound to. This is not always the same +-- port as that given in the argument. For example, binding to port 0 actually +-- binds to a random port, selected by the OS. +forkServer :: N.HostName -- ^ Host + -> N.ServiceName -- ^ Port + -> Int -- ^ Backlog (maximum number of queued connections) + -> Bool -- ^ Set ReuseAddr option? + -> (SomeException -> IO ()) -- ^ Error handler. Called with an + -- exception raised when + -- accepting a connection. + -> (SomeException -> IO ()) -- ^ Termination handler. Called + -- when the error handler throws + -- an exception. + -> (IO () -> (N.Socket, N.SockAddr) -> IO ()) + -- ^ Request handler. Gets an + -- action which completes when + -- the socket is closed. + -> IO (N.ServiceName, ThreadId) +forkServer host port backlog reuseAddr errorHandler terminationHandler requestHandler = do + -- Resolve the specified address. By specification, getAddrInfo will never + -- return an empty list (but will throw an exception instead) and will return + -- the "best" address first, whatever that means + addr:_ <- N.getAddrInfo (Just N.defaultHints) (Just host) (Just port) + bracketOnError (N.socket (N.addrFamily addr) N.Stream N.defaultProtocol) + tryCloseSocket $ \sock -> do + when reuseAddr $ N.setSocketOption sock N.ReuseAddr 1 + N.bind sock (N.addrAddress addr) + N.listen sock backlog + + -- Close up and fill the synchonizing MVar. + let release :: ((N.Socket, N.SockAddr), MVar ()) -> IO () + release ((sock, _), socketClosed) = + N.close sock `finally` putMVar socketClosed () + + -- Run the request handler. + let act restore (sock, sockAddr) = do + socketClosed <- newEmptyMVar + void $ forkIO $ restore $ do + requestHandler (readMVar socketClosed) (sock, sockAddr) + `finally` + release ((sock, sockAddr), socketClosed) + + let acceptRequest :: IO () + acceptRequest = mask $ \restore -> do + -- Async exceptions are masked so that, if accept does give a + -- socket, we'll always deliver it to the handler before the + -- exception is raised. + -- If it's a Right handler then it will eventually be closed. + -- If it's a Left handler then we assume the handler itself will + -- close it. + (sock, sockAddr) <- N.accept sock + -- Looks like 'act' will never throw an exception, but to be + -- safe we'll close the socket if it does. + let handler :: SomeException -> IO () + handler _ = N.close sock + catch (act restore (sock, sockAddr)) handler + + -- We start listening for incoming requests in a separate thread. When + -- that thread is killed, we close the server socket and the termination + -- handler is run. We have to make sure that the exception handler is + -- installed /before/ any asynchronous exception occurs. So we mask_, then + -- fork (the child thread inherits the masked state from the parent), then + -- unmask only inside the catch. + (,) <$> fmap show (N.socketPort sock) <*> + (mask_ $ forkIOWithUnmask $ \unmask -> + catch (unmask (forever (catch acceptRequest errorHandler))) $ \ex -> do + tryCloseSocket sock + terminationHandler ex) + +-- | Read a length and then a payload of that length, subject to a limit +-- on the length. +-- If the length (first 'Word32' received) is greater than the limit then +-- an exception is thrown. +recvWithLength :: Word32 -> N.Socket -> IO [ByteString] +recvWithLength limit sock = do + len <- recvWord32 sock + when (len > limit) $ + throwIO (userError "recvWithLength: limit exceeded") + recvExact sock len + +-- | Receive a 32-bit unsigned integer +recvWord32 :: N.Socket -> IO Word32 +recvWord32 = fmap (decodeWord32 . BS.concat) . flip recvExact 4 + +-- | Close a socket, ignoring I/O exceptions. +tryCloseSocket :: N.Socket -> IO () +tryCloseSocket sock = void . tryIO $ + N.close sock + +-- | Shutdown socket sends and receives, ignoring I/O exceptions. +tryShutdownSocketBoth :: N.Socket -> IO () +tryShutdownSocketBoth sock = void . tryIO $ + N.shutdown sock N.ShutdownBoth + +-- | Read an exact number of bytes from a socket +-- +-- Throws an I/O exception if the socket closes before the specified +-- number of bytes could be read +recvExact :: N.Socket -- ^ Socket to read from + -> Word32 -- ^ Number of bytes to read + -> IO [ByteString] -- ^ Data read +recvExact sock len = go [] len + where + go :: [ByteString] -> Word32 -> IO [ByteString] + go acc 0 = return (reverse acc) + go acc l = do + bs <- NBS.recv sock (fromIntegral l `min` smallChunkSize) + if BS.null bs + then throwIO (userError "recvExact: Socket closed") + else go (bs : acc) (l - fromIntegral (BS.length bs)) + +-- | Get the numeric host, resolved host (via getNameInfo), and port from a +-- SockAddr. The numeric host is first, then resolved host (which may be the +-- same as the numeric host). +-- Will only give 'Just' for IPv4 addresses. +resolveSockAddr :: N.SockAddr -> IO (Maybe (N.HostName, N.HostName, N.ServiceName)) +resolveSockAddr sockAddr = case sockAddr of + N.SockAddrInet port _ -> do + (mResolvedHost, mResolvedPort) <- N.getNameInfo [] True False sockAddr + case (mResolvedHost, mResolvedPort) of + (Just resolvedHost, Nothing) -> do + (Just numericHost, _) <- N.getNameInfo [N.NI_NUMERICHOST] True False sockAddr + return $ Just (numericHost, resolvedHost, show port) + _ -> error $ concat [ + "decodeSockAddr: unexpected resolution " + , show sockAddr + , " -> " + , show mResolvedHost + , ", " + , show mResolvedPort + ] + _ -> return Nothing + +-- | Encode end point address +encodeEndPointAddress :: N.HostName + -> N.ServiceName + -> EndPointId + -> EndPointAddress +encodeEndPointAddress host port ix = EndPointAddress . BSC.pack $ + host ++ ":" ++ port ++ ":" ++ show ix + +-- | Decode end point address +decodeEndPointAddress :: EndPointAddress + -> Maybe (N.HostName, N.ServiceName, EndPointId) +decodeEndPointAddress (EndPointAddress bs) = + case splitMaxFromEnd (== ':') 2 $ BSC.unpack bs of + [host, port, endPointIdStr] -> + case reads endPointIdStr of + [(endPointId, "")] -> Just (host, port, endPointId) + _ -> Nothing + _ -> + Nothing + +-- | @spltiMaxFromEnd p n xs@ splits list @xs@ at elements matching @p@, +-- returning at most @p@ segments -- counting from the /end/ +-- +-- > splitMaxFromEnd (== ':') 2 "ab:cd:ef:gh" == ["ab:cd", "ef", "gh"] +splitMaxFromEnd :: (a -> Bool) -> Int -> [a] -> [[a]] +splitMaxFromEnd p = \n -> go [[]] n . reverse + where + -- go :: [[a]] -> Int -> [a] -> [[a]] + go accs _ [] = accs + go ([] : accs) 0 xs = reverse xs : accs + go (acc : accs) n (x:xs) = + if p x then go ([] : acc : accs) (n - 1) xs + else go ((x : acc) : accs) n xs + go _ _ _ = error "Bug in splitMaxFromEnd" diff --git a/packages/network-transport-tcp/src/Network/Transport/TCP/Mock/Socket.hs b/packages/network-transport-tcp/src/Network/Transport/TCP/Mock/Socket.hs new file mode 100644 index 00000000..85ed3c8c --- /dev/null +++ b/packages/network-transport-tcp/src/Network/Transport/TCP/Mock/Socket.hs @@ -0,0 +1,359 @@ +{-# LANGUAGE EmptyDataDecls #-} +module Network.Transport.TCP.Mock.Socket + ( -- * Types + HostName + , ServiceName + , Socket + , SocketType(..) + , SocketOption(..) + , AddrInfo(..) + , Family + , SockAddr + , ProtocolNumber + , ShutdownCmd(..) + -- * Functions + , getAddrInfo + , socket + , bindSocket + , listen + , setSocketOption + , accept + , sClose + , connect + , shutdown + -- * Constants + , defaultHints + , defaultProtocol + , sOMAXCONN + -- * Debugging API + , scheduleReadAction + -- * Internal API + , writeSocket + , readSocket + , Message(..) + ) where + +import Data.Word (Word8) +import Data.Map (Map) +import qualified Data.Map as Map +import Control.Exception (throwIO) +import Control.Category ((>>>)) +import Control.Concurrent.MVar +import Control.Concurrent.Chan +import System.IO.Unsafe (unsafePerformIO) +import Data.Accessor (Accessor, accessor, (^=), (^.), (^:)) +import qualified Data.Accessor.Container as DAC (mapMaybe) +import System.Timeout (timeout) + +-------------------------------------------------------------------------------- +-- Mock state -- +-------------------------------------------------------------------------------- + +data MockState = MockState { + _boundSockets :: !(Map SockAddr Socket) + , _nextSocketId :: !Int + , _validHostnames :: [HostName] + } + +initialMockState :: MockState +initialMockState = MockState { + _boundSockets = Map.empty + , _nextSocketId = 0 + , _validHostnames = ["localhost", "127.0.0.1"] + } + +mockState :: MVar MockState +{-# NOINLINE mockState #-} +mockState = unsafePerformIO $ newMVar initialMockState + +get :: Accessor MockState a -> IO a +get acc = timeoutThrow mvarThreshold $ withMVar mockState $ return . (^. acc) + +set :: Accessor MockState a -> a -> IO () +set acc val = timeoutThrow mvarThreshold $ modifyMVar_ mockState $ return . (acc ^= val) + +boundSockets :: Accessor MockState (Map SockAddr Socket) +boundSockets = accessor _boundSockets (\bs st -> st { _boundSockets = bs }) + +boundSocketAt :: SockAddr -> Accessor MockState (Maybe Socket) +boundSocketAt addr = boundSockets >>> DAC.mapMaybe addr + +nextSocketId :: Accessor MockState Int +nextSocketId = accessor _nextSocketId (\sid st -> st { _nextSocketId = sid }) + +validHostnames :: Accessor MockState [HostName] +validHostnames = accessor _validHostnames (\ns st -> st { _validHostnames = ns }) + +-------------------------------------------------------------------------------- +-- The public API (mirroring Network.Socket) -- +-------------------------------------------------------------------------------- + +type HostName = String +type ServiceName = String +type PortNumber = String +type HostAddress = String + +data SocketType = Stream +data SocketOption = ReuseAddr +data ShutdownCmd = ShutdownSend + +data Family +data ProtocolNumber + +data Socket = Socket { + socketState :: MVar SocketState + , socketDescription :: String + } + +data SocketState = + Uninit + | BoundSocket { + socketBacklog :: Chan (Socket, SockAddr, MVar Socket) + } + | Connected { + socketBuff :: Chan Message + , _socketPeer :: Maybe Socket + , _scheduledReadActions :: [(Int, IO ())] + } + | Closed + +data Message = + Payload Word8 + | CloseSocket + +data AddrInfo = AddrInfo { + addrFamily :: Family + , addrAddress :: SockAddr + } + +data SockAddr = SockAddrInet PortNumber HostAddress + deriving (Eq, Ord, Show) + +instance Show AddrInfo where + show = show . addrAddress + +instance Show Socket where + show sock = "<>" + +socketPeer :: Accessor SocketState (Maybe Socket) +socketPeer = accessor _socketPeer (\peer st -> st { _socketPeer = peer }) + +scheduledReadActions :: Accessor SocketState [(Int, IO ())] +scheduledReadActions = accessor _scheduledReadActions (\acts st -> st { _scheduledReadActions = acts }) + +getAddrInfo :: Maybe AddrInfo -> Maybe HostName -> Maybe ServiceName -> IO [AddrInfo] +getAddrInfo _ (Just host) (Just port) = do + validHosts <- get validHostnames + if host `elem` validHosts + then return . return $ AddrInfo { + addrFamily = error "Family unused" + , addrAddress = SockAddrInet port host + } + else throwSocketError $ "getAddrInfo: invalid hostname '" ++ host ++ "'" +getAddrInfo _ _ _ = error "getAddrInfo: unsupported arguments" + +defaultHints :: AddrInfo +defaultHints = error "defaultHints not implemented" + +socket :: Family -> SocketType -> ProtocolNumber -> IO Socket +socket _ Stream _ = do + state <- newMVar Uninit + sid <- get nextSocketId + set nextSocketId (sid + 1) + return Socket { + socketState = state + , socketDescription = show sid + } + +bindSocket :: Socket -> SockAddr -> IO () +bindSocket sock addr = do + timeoutThrow mvarThreshold $ modifyMVar_ (socketState sock) $ \st -> case st of + Uninit -> do + backlog <- newChan + return BoundSocket { + socketBacklog = backlog + } + _ -> + throwSocketError "bind: socket already initialized" + set (boundSocketAt addr) (Just sock) + +listen :: Socket -> Int -> IO () +listen _ _ = return () + +defaultProtocol :: ProtocolNumber +defaultProtocol = error "defaultProtocol not implemented" + +setSocketOption :: Socket -> SocketOption -> Int -> IO () +setSocketOption _ ReuseAddr 1 = return () +setSocketOption _ _ _ = error "setSocketOption: unsupported arguments" + +accept :: Socket -> IO (Socket, SockAddr) +accept serverSock = do + backlog <- timeoutThrow mvarThreshold $ withMVar (socketState serverSock) $ \st -> case st of + BoundSocket {} -> + return (socketBacklog st) + _ -> + throwSocketError "accept: socket not bound" + (theirSocket, theirAddress, reply) <- readChan backlog + ourBuff <- newChan + ourState <- newMVar Connected { + socketBuff = ourBuff + , _socketPeer = Just theirSocket + , _scheduledReadActions = [] + } + let ourSocket = Socket { + socketState = ourState + , socketDescription = "" + } + timeoutThrow mvarThreshold $ putMVar reply ourSocket + return (ourSocket, theirAddress) + +sClose :: Socket -> IO () +sClose sock = do + -- Close the peer socket + writeSocket sock CloseSocket + + -- Close our socket + timeoutThrow mvarThreshold $ modifyMVar_ (socketState sock) $ \st -> + case st of + Connected {} -> do + -- In case there is a parallel read stuck on a readChan + writeChan (socketBuff st) CloseSocket + return Closed + _ -> + return Closed + +connect :: Socket -> SockAddr -> IO () +connect us serverAddr = do + mServer <- get (boundSocketAt serverAddr) + case mServer of + Just server -> do + serverBacklog <- timeoutThrow mvarThreshold $ withMVar (socketState server) $ \st -> case st of + BoundSocket {} -> + return (socketBacklog st) + _ -> + throwSocketError "connect: server socket not bound" + reply <- newEmptyMVar + writeChan serverBacklog (us, SockAddrInet "" "", reply) + them <- timeoutThrow mvarThreshold $ readMVar reply + timeoutThrow mvarThreshold $ modifyMVar_ (socketState us) $ \st -> case st of + Uninit -> do + buff <- newChan + return Connected { + socketBuff = buff + , _socketPeer = Just them + , _scheduledReadActions = [] + } + _ -> + throwSocketError "connect: already connected" + Nothing -> throwSocketError "connect: unknown address" + +sOMAXCONN :: Int +sOMAXCONN = error "sOMAXCONN not implemented" + +shutdown :: Socket -> ShutdownCmd -> IO () +shutdown sock ShutdownSend = do + writeSocket sock CloseSocket + timeoutThrow mvarThreshold $ modifyMVar_ (socketState sock) $ \st -> case st of + Connected {} -> + return (socketPeer ^= Nothing $ st) + _ -> + return st + +-------------------------------------------------------------------------------- +-- Functions with no direct public counterpart -- +-------------------------------------------------------------------------------- + +peerBuffer :: Socket -> IO (Either String (Chan Message)) +peerBuffer sock = do + mPeer <- timeoutThrow mvarThreshold $ withMVar (socketState sock) $ \st -> case st of + Connected {} -> + return (st ^. socketPeer) + _ -> + return Nothing + case mPeer of + Just peer -> timeoutThrow mvarThreshold $ withMVar (socketState peer) $ \st -> case st of + Connected {} -> + return (Right (socketBuff st)) + _ -> + return (Left "Peer socket closed") + Nothing -> + return (Left "Socket closed") + +throwSocketError :: String -> IO a +throwSocketError = throwIO . userError + +writeSocket :: Socket -> Message -> IO () +writeSocket sock msg = do + theirBuff <- peerBuffer sock + case theirBuff of + Right buff -> writeChan buff msg + Left err -> case msg of Payload _ -> throwSocketError $ "writeSocket: " ++ err + CloseSocket -> return () + +readSocket :: Socket -> IO (Maybe Word8) +readSocket sock = do + mBuff <- timeoutThrow mvarThreshold $ modifyMVar (socketState sock) $ \st -> case st of + Connected {} -> do + let (later, now) = tick $ st ^. scheduledReadActions + return ( scheduledReadActions ^= later $ st + , Just (socketBuff st, now) + ) + _ -> + return (st, Nothing) + case mBuff of + Just (buff, actions) -> do + sequence actions + msg <- timeoutThrow readSocketThreshold $ readChan buff + case msg of + Payload w -> return (Just w) + CloseSocket -> timeoutThrow mvarThreshold $ modifyMVar (socketState sock) $ \st -> case st of + Connected {} -> + return (Closed, Nothing) + _ -> + throwSocketError "readSocket: socket in unexpected state" + Nothing -> + return Nothing + +-- | Given a list of scheduled actions, reduce all delays by 1, and return the +-- actions that should be executed now. +tick :: [(Int, IO ())] -> ([(Int, IO ())], [IO ()]) +tick = go [] [] + where + go later now [] = (reverse later, reverse now) + go later now ((n, action) : actions) + | n == 0 = go later (action : now) actions + | otherwise = go ((n - 1, action) : later) now actions + +-------------------------------------------------------------------------------- +-- Debugging API -- +-------------------------------------------------------------------------------- + +-- | Schedule an action to be executed after /n/ reads on this socket +-- +-- If /n/ is zero we execute the action immediately. +scheduleReadAction :: Socket -> Int -> IO () -> IO () +scheduleReadAction _ 0 action = action +scheduleReadAction sock n action = + modifyMVar_ (socketState sock) $ \st -> case st of + Connected {} -> + return (scheduledReadActions ^: ((n, action) :) $ st) + _ -> + throwSocketError "scheduleReadAction: socket not connected" + +-------------------------------------------------------------------------------- +-- Util -- +-------------------------------------------------------------------------------- + +mvarThreshold :: Int +mvarThreshold = 1000000 + +readSocketThreshold :: Int +readSocketThreshold = 10000000 + +timeoutThrow :: Int -> IO a -> IO a +timeoutThrow n p = do + ma <- timeout n p + case ma of + Just a -> return a + Nothing -> throwIO (userError "timeout") diff --git a/packages/network-transport-tcp/src/Network/Transport/TCP/Mock/Socket/ByteString.hs b/packages/network-transport-tcp/src/Network/Transport/TCP/Mock/Socket/ByteString.hs new file mode 100644 index 00000000..24be4e44 --- /dev/null +++ b/packages/network-transport-tcp/src/Network/Transport/TCP/Mock/Socket/ByteString.hs @@ -0,0 +1,27 @@ +module Network.Transport.TCP.Mock.Socket.ByteString + ( sendMany + , recv + ) where + +import Data.ByteString (ByteString) +import qualified Data.ByteString as BSS (pack, foldl) +import Data.Word (Word8) +import Control.Applicative ((<$>)) +import Network.Transport.TCP.Mock.Socket + +sendMany :: Socket -> [ByteString] -> IO () +sendMany sock = mapM_ (bsMapM_ (writeSocket sock . Payload)) + where + bsMapM_ :: (Word8 -> IO ()) -> ByteString -> IO () + bsMapM_ p = BSS.foldl (\io w -> io >> p w) (return ()) + +recv :: Socket -> Int -> IO ByteString +recv sock = \n -> BSS.pack <$> go [] n + where + go :: [Word8] -> Int -> IO [Word8] + go acc 0 = return (reverse acc) + go acc n = do + mw <- readSocket sock + case mw of + Just w -> go (w : acc) (n - 1) + Nothing -> return (reverse acc) diff --git a/packages/network-transport-tcp/tests/TestQC.hs b/packages/network-transport-tcp/tests/TestQC.hs new file mode 100644 index 00000000..c80ffa00 --- /dev/null +++ b/packages/network-transport-tcp/tests/TestQC.hs @@ -0,0 +1,848 @@ +-- Test the TCP transport using QuickCheck generated scripts +-- +-- TODO: This is not quite working yet. The main problem, I think, is the +-- allocation of "bundle ID"s to connections. The problem is exposed by the +-- aptly-named regression test script_Foo (to be renamed once I figure out what +-- bug that test is actually exposing :) +module Main + ( main + -- Shush the compiler about unused definitions + , log + , logShow + , forAllShrink + , inits + , expectedFailure + ) where + +import Prelude hiding (log) +import Test.Framework (Test, TestName, defaultMain, testGroup) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.Framework.Providers.HUnit (testCase) +import Test.QuickCheck + ( Gen + , choose + , suchThatMaybe + , forAll + , forAllShrink + , Property + , Arbitrary(arbitrary) + ) +import Test.QuickCheck.Property (morallyDubiousIOProperty, Result(..), result) +import Test.HUnit (Assertion, assertFailure) +import Data.Map (Map) +import qualified Data.Map as Map +import Control.Category ((>>>)) +import Control.Applicative ((<$>)) +import Control.Exception (Exception, throwIO, try) +import Control.Concurrent (forkIO, threadDelay, ThreadId, killThread) +import Control.Monad (MonadPlus(..), replicateM, forever, guard) +import Control.Monad.State (StateT, execStateT) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Typeable (Typeable) +import Data.Maybe (isJust) +import Data.List (inits) +import Data.ByteString (ByteString) +import Data.ByteString.Char8 (pack) +import Data.Accessor (Accessor, accessor, (^.)) +import Data.Accessor.Monad.Trans.State (get, set, modify) +import qualified Data.Accessor.Container as DAC (set, mapDefault) +import qualified Data.ByteString as BSS (concat) +import qualified Text.PrettyPrint as PP +import Data.Unique (Unique, newUnique, hashUnique) +import Data.Concurrent.Queue.MichaelScott (newQ, pushL, tryPopR) +import Data.Set (Set) +import qualified Data.Set as Set +import GHC.Stack (currentCallStack, renderStack) + +import Network.Transport +import Network.Transport.TCP + ( createTransportExposeInternals + , defaultTCPParameters + , TransportInternals(socketBetween) + ) +import Network.Transport.TCP.Mock.Socket (Socket, scheduleReadAction, sClose) + +-------------------------------------------------------------------------------- +-- Script infrastructure -- +-------------------------------------------------------------------------------- + +type EndPointIx = Int +type SourceEndPointIx = Int +type TargetEndPointIx = Int +type ConnectionIx = Int + +-- | We randomly generate /scripts/ which are essentially a deep embedding of +-- the Transport API. These scripts are then executed and the results compared +-- against an abstract interpreter. +data ScriptCmd = + -- | Create a new endpoint + NewEndPoint + -- | @Connect i j@ creates a connection from endpoint @i@ to endpoint @j@, + -- where @i@ and @j@ are indices and refer to the @i@th and @j@th endpoint + -- created by NewEndPoint + | Connect SourceEndPointIx TargetEndPointIx + -- | @Close i@ closes the @i@ connection created using 'Connect'. Note that + -- closing a connection does not shift other indices; in other words, in + -- @[Connect 0 0, Close 0, Connect 0 0, Close 0]@ the second 'Close' + -- refers to the first (already closed) connection + | Close ConnectionIx + -- | @Send i bs@ sends payload @bs@ on the @i@ connection created + | Send ConnectionIx [ByteString] + -- | @BreakAfterReads n i j@ force-closes the socket between endpoints @i@ + -- and @j@ after @n@ reads by @i@ + -- + -- We should have @i /= j@ because the TCP transport does not use sockets + -- for connections from an endpoint to itself + | BreakAfterReads Int SourceEndPointIx TargetEndPointIx + deriving Show + +type Script = [ScriptCmd] + +-------------------------------------------------------------------------------- +-- Execute and verify scripts -- +-------------------------------------------------------------------------------- + +data Variable a = Value a | Variable Unique + deriving Eq + +instance Show a => Show (Variable a) where + show (Value x) = show x + show (Variable u) = "<<" ++ show (hashUnique u) ++ ">>" + +-- | In the implementation "bundles" are purely a conceptual idea, but in the +-- verifier we need to concretize this notion +type BundleId = Int + +data ConnectionInfo = ConnectionInfo { + source :: EndPointAddress + , target :: EndPointAddress + , connectionId :: Variable ConnectionId + , connectionBundle :: BundleId + } + deriving Show + +data ExpEvent = + ExpConnectionOpened ConnectionInfo + | ExpConnectionClosed ConnectionInfo + | ExpReceived ConnectionInfo [ByteString] + | ExpConnectionLost BundleId EndPointAddress + deriving Show + +data RunState = RunState { + _endPoints :: [EndPoint] + , _connections :: [(Connection, ConnectionInfo)] + , _expectedEvents :: Map EndPointAddress [ExpEvent] + -- | For each endpoint we create we create a thread that forwards the events + -- of that endpoint to a central channel. We collect the thread IDs so that + -- we can kill these thread when we are done. + , _forwardingThreads :: [ThreadId] + -- | When a connection from A to be may break, we add both (A, B, n) + -- and (B, A, n) to _mayBreak. Then once we detect that from A to B + -- has in fact broken we move (A, B, n), *and/or* (B, A, n), from _mayBreak + -- to _broken. Note that we can detect that a connection has been broken + -- in one direction even if we haven't yet detected that the connection + -- has broken in the other direction. + -- + -- | Invariant: not mayBreak && broken + , _mayBreak :: Set (EndPointAddress, EndPointAddress, BundleId) + , _broken :: Set (EndPointAddress, EndPointAddress, BundleId) + -- | Current bundle ID between two endpoints + -- + -- Invariant: For all keys (A, B), A <= B + , _currentBundle :: Map (EndPointAddress, EndPointAddress) BundleId + } + +initialRunState :: RunState +initialRunState = RunState { + _endPoints = [] + , _connections = [] + , _expectedEvents = Map.empty + , _forwardingThreads = [] + , _mayBreak = Set.empty + , _broken = Set.empty + , _currentBundle = Map.empty + } + +verify :: (Transport, TransportInternals) -> Script -> IO (Either String ()) +verify (transport, transportInternals) script = do + allEvents <- newQ + + let runScript :: Script -> StateT RunState IO () + runScript = mapM_ runCmd + + runCmd :: ScriptCmd -> StateT RunState IO () + runCmd NewEndPoint = do + mEndPoint <- liftIO $ newEndPoint transport + case mEndPoint of + Right endPoint -> do + tid <- liftIO $ forkIO (forward endPoint) + append endPoints endPoint + append forwardingThreads tid + set (expectedEventsAt (address endPoint)) [] + Left err -> + liftIO $ throwIO err + runCmd (Connect i j) = do + endPointA <- get (endPointAtIx i) + endPointB <- address <$> get (endPointAtIx j) + mConn <- liftIO $ connect endPointA endPointB ReliableOrdered defaultConnectHints + let bundleId = currentBundle (address endPointA) endPointB + connBroken = broken (address endPointA) endPointB + connMayBreak = mayBreak (address endPointA) endPointB + case mConn of + Right conn -> do + bundleBroken <- get bundleId >>= get . connBroken + currentBundleId <- if bundleBroken + then modify bundleId (+ 1) >> get bundleId + else get bundleId + connId <- Variable <$> liftIO newUnique + let connInfo = ConnectionInfo { + source = address endPointA + , target = endPointB + , connectionId = connId + , connectionBundle = currentBundleId + } + append connections (conn, connInfo) + append (expectedEventsAt endPointB) (ExpConnectionOpened connInfo) + Left err -> do + currentBundleId <- get bundleId + expectingBreak <- get $ connMayBreak currentBundleId + if expectingBreak + then do + set (connMayBreak currentBundleId) False + set (connBroken currentBundleId) True + else + liftIO $ throwIO err + runCmd (Close i) = do + (conn, connInfo) <- get (connectionAt i) + liftIO $ close conn + append (expectedEventsAt (target connInfo)) (ExpConnectionClosed connInfo) + runCmd (Send i payload) = do + (conn, connInfo) <- get (connectionAt i) + mResult <- liftIO $ send conn payload + let connMayBreak = mayBreak (source connInfo) (target connInfo) (connectionBundle connInfo) + connBroken = broken (source connInfo) (target connInfo) (connectionBundle connInfo) + case mResult of + Right () -> return () + Left err -> do + expectingBreak <- get connMayBreak + isBroken <- get connBroken + if expectingBreak || isBroken + then do + set connMayBreak False + set connBroken True + else + liftIO $ throwIO err + append (expectedEventsAt (target connInfo)) (ExpReceived connInfo payload) + -- TODO: This will only work if a connection between 'i' and 'j' has + -- already been established. We would need to modify the mock network + -- layer to support breaking "future" connections + runCmd (BreakAfterReads n i j) = do + endPointA <- address <$> get (endPointAtIx i) + endPointB <- address <$> get (endPointAtIx j) + liftIO $ do + sock <- socketBetween transportInternals endPointA endPointB + scheduleReadAction sock n $ breakSocket sock + currentBundleId <- get (currentBundle endPointA endPointB) + set (mayBreak endPointA endPointB currentBundleId) True + set (mayBreak endPointB endPointA currentBundleId) True + append (expectedEventsAt endPointA) (ExpConnectionLost currentBundleId endPointB) + append (expectedEventsAt endPointB) (ExpConnectionLost currentBundleId endPointA) + + forward :: EndPoint -> IO () + forward endPoint = forever $ do + ev <- receive endPoint + pushL allEvents (address endPoint, ev) + + collectEvents :: RunState -> IO (Map EndPointAddress [Event]) + collectEvents st = do + threadDelay 10000 + mapM_ killThread (st ^. forwardingThreads) + evs <- go [] + return $ groupByKey (map address (st ^. endPoints)) evs + where + go acc = do + mEv <- tryPopR allEvents + case mEv of + Just ev -> go (ev : acc) + Nothing -> return (reverse acc) + + st <- execStateT (runScript script) initialRunState + actualEvents <- collectEvents st + + let eventsMatch = all (uncurry match) $ + zip (Map.elems (st ^. expectedEvents)) + (Map.elems actualEvents) + + return $ if eventsMatch + then Right () + else Left ("Could not match " ++ show (st ^. expectedEvents) + ++ " and " ++ show actualEvents) + +breakSocket :: Socket -> IO () +breakSocket sock = do + currentCallStack >>= putStrLn . renderStack + sClose sock + +-------------------------------------------------------------------------------- +-- Match expected and actual events -- +-------------------------------------------------------------------------------- + +-- | Match a list of expected events to a list of actual events, taking into +-- account that events may be reordered +match :: [ExpEvent] -> [Event] -> Bool +match expected actual = any (`canUnify` actual) (possibleTraces expected) + +possibleTraces :: [ExpEvent] -> [[ExpEvent]] +possibleTraces = go + where + go [] = [[]] + go (ev@(ExpConnectionLost _ _) : evs) = + [ trace | evs' <- possibleTraces evs, trace <- insertConnectionLost ev evs' ] + go (ev : evs) = + [ trace | evs' <- possibleTraces evs, trace <- insertEvent ev evs' ] + + -- We don't know when exactly the error will occur (indeed, it may never + -- happen at all), but it must occur before any future connection lost + -- event to the same destination. + -- If it occurs now, then all other events on this bundle will not happen. + insertConnectionLost :: ExpEvent -> [ExpEvent] -> [[ExpEvent]] + insertConnectionLost ev [] = [[ev], []] + insertConnectionLost ev@(ExpConnectionLost bid addr) (ev' : evs) = + (ev : removeBundle bid (ev' : evs)) : + case ev' of + ExpConnectionLost _ addr' | addr == addr' -> [] + _ -> [ev' : evs' | evs' <- insertConnectionLost ev evs] + insertConnectionLost _ _ = error "The impossible happened" + + -- All other events can be arbitrarily reordered /across/ connections, but + -- never /within/ connections + insertEvent :: ExpEvent -> [ExpEvent] -> [[ExpEvent]] + insertEvent ev [] = [[ev]] + insertEvent ev (ev' : evs) = + (ev : ev' : evs) : + if eventConnId ev == eventConnId ev' + then [] + else [ev' : evs' | evs' <- insertEvent ev evs] + + removeBundle :: BundleId -> [ExpEvent] -> [ExpEvent] + removeBundle bid = filter ((/= bid) . eventBundleId) + + eventBundleId :: ExpEvent -> BundleId + eventBundleId (ExpConnectionOpened connInfo) = connectionBundle connInfo + eventBundleId (ExpConnectionClosed connInfo) = connectionBundle connInfo + eventBundleId (ExpReceived connInfo _) = connectionBundle connInfo + eventBundleId (ExpConnectionLost bid _) = bid + + eventConnId :: ExpEvent -> Maybe (Variable ConnectionId) + eventConnId (ExpConnectionOpened connInfo) = Just $ connectionId connInfo + eventConnId (ExpConnectionClosed connInfo) = Just $ connectionId connInfo + eventConnId (ExpReceived connInfo _) = Just $ connectionId connInfo + eventConnId (ExpConnectionLost _ _) = Nothing + +-------------------------------------------------------------------------------- +-- Unification -- +-------------------------------------------------------------------------------- + +type Substitution = Map Unique ConnectionId + +newtype Unifier a = Unifier { + runUnifier :: Substitution -> Maybe (a, Substitution) + } + +instance Monad Unifier where + return x = Unifier $ \subst -> Just (x, subst) + x >>= f = Unifier $ \subst -> case runUnifier x subst of + Nothing -> Nothing + Just (a, subst') -> runUnifier (f a) subst' + fail _str = mzero + +instance MonadPlus Unifier where + mzero = Unifier $ const Nothing + f `mplus` g = Unifier $ \subst -> case runUnifier f subst of + Nothing -> runUnifier g subst + Just (a, subst') -> Just (a, subst') + +class Unify a b where + unify :: a -> b -> Unifier () + +canUnify :: Unify a b => a -> b -> Bool +canUnify a b = isJust $ runUnifier (unify a b) Map.empty + +instance Unify Unique ConnectionId where + unify x cid = Unifier $ \subst -> + case Map.lookup x subst of + Just cid' -> if cid == cid' then Just ((), subst) + else Nothing + Nothing -> Just ((), Map.insert x cid subst) + +instance Unify (Variable ConnectionId) ConnectionId where + unify (Variable x) connId = unify x connId + unify (Value connId') connId = guard $ connId' == connId + +instance Unify ExpEvent Event where + unify (ExpConnectionOpened connInfo) (ConnectionOpened connId _ _) = + unify (connectionId connInfo) connId + unify (ExpConnectionClosed connInfo) (ConnectionClosed connId) = + unify (connectionId connInfo) connId + unify (ExpReceived connInfo payload) (Received connId payload') = do + guard $ BSS.concat payload == BSS.concat payload' + unify (connectionId connInfo) connId + unify (ExpConnectionLost _ addr) (ErrorEvent (TransportError (EventConnectionLost addr') _)) = + guard $ addr == addr' + unify _ _ = fail "Cannot unify" + +instance Unify a b => Unify [a] [b] where + unify [] [] = return () + unify (x:xs) (y:ys) = unify x y >> unify xs ys + unify _ _ = fail "Cannot unify" + +-------------------------------------------------------------------------------- +-- Script generators -- +-------------------------------------------------------------------------------- + +script_NewEndPoint :: Int -> Gen Script +script_NewEndPoint numEndPoints = return (replicate numEndPoints NewEndPoint) + +script_Connect :: Int -> Gen Script +script_Connect numEndPoints = do + script <- go + return (replicate numEndPoints NewEndPoint ++ script) + where + go :: Gen Script + go = do + next <- choose (0, 1) :: Gen Int + case next of + 0 -> do + fr <- choose (0, numEndPoints - 1) + to <- choose (0, numEndPoints - 1) + cmds <- go + return (Connect fr to : cmds) + _ -> + return [] + +script_ConnectClose :: Int -> Gen Script +script_ConnectClose numEndPoints = do + script <- go Map.empty + return (replicate numEndPoints NewEndPoint ++ script) + where + go :: Map Int Bool -> Gen Script + go conns = do + next <- choose (0, 2) :: Gen Int + case next of + 0 -> do + fr <- choose (0, numEndPoints - 1) + to <- choose (0, numEndPoints - 1) + cmds <- go (Map.insert (Map.size conns) True conns) + return (Connect fr to : cmds) + 1 -> do + mConn <- choose (0, Map.size conns - 1) `suchThatMaybe` isOpen conns + case mConn of + Nothing -> go conns + Just conn -> do + cmds <- go (Map.insert conn False conns) + return (Close conn : cmds) + _ -> + return [] + + isOpen :: Map Int Bool -> Int -> Bool + isOpen conns connIx = connIx `Map.member` conns && conns Map.! connIx + +script_ConnectSendClose :: Int -> Gen Script +script_ConnectSendClose numEndPoints = do + script <- go Map.empty + return (replicate numEndPoints NewEndPoint ++ script) + where + go :: Map Int Bool -> Gen Script + go conns = do + next <- choose (0, 3) :: Gen Int + case next of + 0 -> do + fr <- choose (0, numEndPoints - 1) + to <- choose (0, numEndPoints - 1) + cmds <- go (Map.insert (Map.size conns) True conns) + return (Connect fr to : cmds) + 1 -> do + mConn <- choose (0, Map.size conns - 1) `suchThatMaybe` isOpen conns + case mConn of + Nothing -> go conns + Just conn -> do + numSegments <- choose (0, 2) + payload <- replicateM numSegments arbitrary + cmds <- go conns + return (Send conn payload : cmds) + 2 -> do + mConn <- choose (0, Map.size conns - 1) `suchThatMaybe` isOpen conns + case mConn of + Nothing -> go conns + Just conn -> do + cmds <- go (Map.insert conn False conns) + return (Close conn : cmds) + _ -> + return [] + + isOpen :: Map Int Bool -> Int -> Bool + isOpen conns connIx = connIx `Map.member` conns && conns Map.! connIx + +withErrors :: Int -> Gen Script -> Gen Script +withErrors numErrors gen = gen >>= insertError numErrors + where + insertError :: Int -> Script -> Gen Script + insertError _ [] = return [] + insertError n (Connect i j : cmds) | i /= j = do + insert <- arbitrary + if insert && n > 0 + then do + numReads <- chooseFrom' NormalD { mean = 5, stdDev = 10 } (0, 100) + swap <- arbitrary + if swap + then return $ Connect i j : BreakAfterReads numReads j i : cmds + else return $ Connect i j : BreakAfterReads numReads i j : cmds + else do + cmds' <- insertError (n - 1) cmds + return $ Connect i j : cmds' + insertError n (cmd : cmds) = do + cmds' <- insertError n cmds + return $ cmd : cmds' + +-------------------------------------------------------------------------------- +-- Individual scripts to test specific bugs -- +-------------------------------------------------------------------------------- + +-- | Bug #1 +-- +-- When process A wants to close the heavyweight connection to process B it +-- sends a CloseSocket request together with the ID of the last connection from +-- B. When B receives the CloseSocket request it can compare this ID to the last +-- connection it created; if they don't match, B knows that there are some +-- messages still on the way from B to A (in particular, a CreatedConnection +-- message) which will cancel the CloseSocket request from A. Hence, it will +-- know to ignore the CloseSocket request from A. +-- +-- The bug was that we recorded the last _created_ outgoing connection on the +-- local endpoint, but the last _received_ incoming connection on the state of +-- the heavyweight connection. So, in the script below, the following happened: +-- +-- A connects to B, records "last connection ID is 1024" +-- A closes the lightweight connection, sends [CloseConnection 1024] +-- A closes the heivyweight connection, sends [CloseSocket 0] +-- +-- (the 0 here indicates that it had not yet received any connections from B) +-- +-- B receives the [CloseSocket 0], compares it to the recorded outgoing ID (0), +-- confirms that they are equal, and confirms the CloseSocket request. +-- +-- B connects to A, records "last connection ID is 1024" +-- B closes the lightweight connection, sends [CloseConnection 1024] +-- B closes the heavyweight connection, sends [CloseSocket 0] +-- +-- (the 0 here indicates that it has not yet received any connections from A, +-- ON THIS HEAVYWEIGHT connection) +-- +-- A receives the [CloseSocket 0] request, compares it to the last recorded +-- outgoing ID (1024), sees that they are not equal, and concludes that this +-- must mean that there is still a CreatedConnection message on the way from A +-- to B. +-- +-- This of course is not the case, so B will wait forever for A to confirm +-- the CloseSocket request, and deadlock arises. (This deadlock doesn't become +-- obvious though until the next attempt from B to connect to A.) +-- +-- The solution is of course that both the recorded outgoing and recorded +-- incoming connection ID must be per heavyweight connection. +script_Bug1 :: Script +script_Bug1 = [ + NewEndPoint + , NewEndPoint + , Connect 0 1 + , Close 0 + , Connect 1 0 + , Close 1 + , Connect 1 0 + ] + +-- | Test ordering of sends +script_MultipleSends :: Script +script_MultipleSends = [ + NewEndPoint + , Connect 0 0 + , Send 0 ["A"] + , Send 0 ["B"] + , Send 0 ["C"] + , Send 0 ["D"] + , Send 0 ["E"] + ] + +-- | Simulate broken network connection during send +script_BreakSend :: Script +script_BreakSend = [ + NewEndPoint + , NewEndPoint + , Connect 0 1 + , BreakAfterReads 1 1 0 + , Send 0 ["ping"] + ] + +-- | Simulate broken network connection during connect +script_BreakConnect1 :: Script +script_BreakConnect1 = [ + NewEndPoint + , NewEndPoint + , Connect 0 1 + , BreakAfterReads 1 1 0 + , Connect 0 1 + ] + +-- | Simulate broken network connection during connect +script_BreakConnect2 :: Script +script_BreakConnect2 = [ + NewEndPoint + , NewEndPoint + , Connect 0 1 + , BreakAfterReads 1 0 1 + , Connect 0 1 + ] + +-- | Simulate broken send, then reconnect +script_BreakSendReconnect :: Script +script_BreakSendReconnect = [ + NewEndPoint + , NewEndPoint + , Connect 0 1 + , BreakAfterReads 1 1 0 + , Send 0 ["ping1"] + , Connect 0 1 + , Send 1 ["ping2"] + ] + +script_Foo :: Script +script_Foo = [ + NewEndPoint + , NewEndPoint + , Connect 1 0 + , BreakAfterReads 2 0 1 + , Send 0 ["pingpong"] + , Connect 0 1 + ] + +-------------------------------------------------------------------------------- +-- Main application driver -- +-------------------------------------------------------------------------------- + +basicTests :: (Transport, TransportInternals) -> Int -> (Gen Script -> Gen Script) -> [Test] +basicTests transport numEndPoints trans = [ + testGen "NewEndPoint" transport (trans (script_NewEndPoint numEndPoints)) + , testGen "Connect" transport (trans (script_Connect numEndPoints)) + , testGen "ConnectClose" transport (trans (script_ConnectClose numEndPoints)) + , testGen "ConnectSendClose" transport (trans (script_ConnectSendClose numEndPoints)) + ] + +tests :: (Transport, TransportInternals) -> [Test] +tests transport = [ + testGroup "Regression tests" [ + testOne "Bug1" transport script_Bug1 + ] + , testGroup "Specific scripts" [ + testOne "BreakMultipleSends" transport script_MultipleSends + , testOne "BreakSend" transport script_BreakSend + , testOne "BreakConnect1" transport script_BreakConnect1 + , testOne "BreakConnect2" transport script_BreakConnect2 + , testOne "BreakSendReconnect" transport script_BreakSendReconnect + , testOne "Foo" transport script_Foo + ] + , testGroup "Without errors" [ + testGroup "One endpoint, with delays" (basicTests transport 1 id) + , testGroup "Two endpoints, with delays" (basicTests transport 2 id) + , testGroup "Three endpoints, with delays" (basicTests transport 3 id) + ] + , testGroup "Single error" [ + testGroup "Two endpoints, with delays" (basicTests transport 2 (withErrors 1)) + , testGroup "Three endpoints, with delays" (basicTests transport 3 (withErrors 1)) + ] + ] + where + +testOne :: TestName -> (Transport, TransportInternals) -> Script -> Test +testOne label transport script = testCase label (testScript transport script) + +testGen :: TestName -> (Transport, TransportInternals) -> Gen Script -> Test +testGen label transport script = testProperty label (testScriptGen transport script) + +main :: IO () +main = do + Right transport <- createTransportExposeInternals "127.0.0.1" "8080" defaultTCPParameters + defaultMain (tests transport) + +-------------------------------------------------------------------------------- +-- Test infrastructure -- +-------------------------------------------------------------------------------- + +testScriptGen :: (Transport, TransportInternals) -> Gen Script -> Property +testScriptGen transport scriptGen = + forAll scriptGen $ \script -> + morallyDubiousIOProperty $ do + logShow script + mErr <- try $ verify transport script + return $ case mErr of + Left (ExpectedFailure str) -> + result { ok = Nothing + , reason = str + } + Right (Left err) -> + result { ok = Just False + , reason = '\n' : err ++ "\n" + } + Right (Right ()) -> + result { ok = Just True } + +testScript :: (Transport, TransportInternals) -> Script -> Assertion +testScript transport script = do + logShow script + mErr <- try $ verify transport script + case mErr of + Left (ExpectedFailure _str) -> + return () + Right (Left err) -> + assertFailure $ "Failed with script " ++ show script ++ ": " ++ err ++ "\n" + Right (Right ()) -> + return () + +-------------------------------------------------------------------------------- +-- Accessors -- +-------------------------------------------------------------------------------- + +endPoints :: Accessor RunState [EndPoint] +endPoints = accessor _endPoints (\es st -> st { _endPoints = es }) + +endPointAtIx :: EndPointIx -> Accessor RunState EndPoint +endPointAtIx i = endPoints >>> listAccessor i + +connections :: Accessor RunState [(Connection, ConnectionInfo)] +connections = accessor _connections (\cs st -> st { _connections = cs }) + +connectionAt :: ConnectionIx -> Accessor RunState (Connection, ConnectionInfo) +connectionAt i = connections >>> listAccessor i + +expectedEvents :: Accessor RunState (Map EndPointAddress [ExpEvent]) +expectedEvents = accessor _expectedEvents (\es st -> st { _expectedEvents = es }) + +expectedEventsAt :: EndPointAddress -> Accessor RunState [ExpEvent] +expectedEventsAt addr = expectedEvents >>> DAC.mapDefault [] addr + +forwardingThreads :: Accessor RunState [ThreadId] +forwardingThreads = accessor _forwardingThreads (\ts st -> st { _forwardingThreads = ts }) + +mayBreak :: EndPointAddress -> EndPointAddress -> BundleId -> Accessor RunState Bool +mayBreak a b bid = aux >>> DAC.set (a, b, bid) + where + aux = accessor _mayBreak (\bs st -> st { _mayBreak = bs }) + +broken :: EndPointAddress -> EndPointAddress -> BundleId -> Accessor RunState Bool +broken a b bid = aux >>> DAC.set (a, b, bid) + where + aux = accessor _broken (\bs st -> st { _broken = bs }) + +currentBundle :: EndPointAddress -> EndPointAddress -> Accessor RunState BundleId +currentBundle i j = aux >>> if i < j then DAC.mapDefault 0 (i, j) + else DAC.mapDefault 0 (j, i) + where + aux :: Accessor RunState (Map (EndPointAddress, EndPointAddress) BundleId) + aux = accessor _currentBundle (\mp st -> st { _currentBundle = mp }) + +-------------------------------------------------------------------------------- +-- Pretty-printing -- +-------------------------------------------------------------------------------- + +verticalList :: Show a => [a] -> PP.Doc +verticalList = PP.brackets . PP.vcat . map (PP.text . show) + +instance Show Script where + show = ("\n" ++) . show . verticalList + +instance Show [Event] where + show = ("\n" ++) . show . verticalList + +instance Show [ExpEvent] where + show = ("\n" ++) . show . verticalList + +instance Show (Map EndPointAddress [ExpEvent]) where + show = ("\n" ++) . show . PP.brackets . PP.vcat + . map (\(addr, evs) -> PP.hcat . PP.punctuate PP.comma $ [PP.text (show addr), verticalList evs]) + . Map.toList + +instance Show (Map EndPointAddress [Event]) where + show = ("\n" ++) . show . PP.brackets . PP.vcat + . map (\(addr, evs) -> PP.hcat . PP.punctuate PP.comma $ [PP.text (show addr), verticalList evs]) + . Map.toList + +-------------------------------------------------------------------------------- +-- Draw random values from probability distributions -- +-------------------------------------------------------------------------------- + +data NormalD = NormalD { mean :: Double , stdDev :: Double } + +class Distribution d where + probabilityOf :: d -> Double -> Double + +instance Distribution NormalD where + probabilityOf d x = a * exp (-0.5 * b * b) + where + a = 1 / (stdDev d * sqrt (2 * pi)) + b = (x - mean d) / stdDev d + +-- | Choose from a distribution +chooseFrom :: Distribution d => d -> (Double, Double) -> Gen Double +chooseFrom d (lo, hi) = findCandidate + where + findCandidate :: Gen Double + findCandidate = do + candidate <- choose (lo, hi) + uniformSample <- choose (0, 1) + if uniformSample < probabilityOf d candidate + then return candidate + else findCandidate + +chooseFrom' :: Distribution d => d -> (Int, Int) -> Gen Int +chooseFrom' d (lo, hi) = + round <$> chooseFrom d (fromIntegral lo, fromIntegral hi) + +-------------------------------------------------------------------------------- +-- Auxiliary +-------------------------------------------------------------------------------- + +log :: String -> IO () +log = appendFile "log" . (++ "\n") + +logShow :: Show a => a -> IO () +logShow = log . show + +instance Arbitrary ByteString where + arbitrary = do + len <- chooseFrom' NormalD { mean = 5, stdDev = 10 } (0, 100) + xs <- replicateM len arbitrary + return (pack xs) + +listAccessor :: Int -> Accessor [a] a +listAccessor i = accessor (!! i) (error "listAccessor.set not defined") + +append :: Monad m => Accessor st [a] -> a -> StateT st m () +append acc x = modify acc (snoc x) + +snoc :: a -> [a] -> [a] +snoc x xs = xs ++ [x] + +groupByKey :: Ord a => [a] -> [(a, b)] -> Map a [b] +groupByKey keys = go (Map.fromList [(key, []) | key <- keys]) + where + go acc [] = Map.map reverse acc + go acc ((key, val) : rest) = go (Map.adjust (val :) key acc) rest + +-------------------------------------------------------------------------------- +-- Expected failures (can't find explicit support for this in test-framework) -- +-------------------------------------------------------------------------------- + +data ExpectedFailure = ExpectedFailure String deriving (Typeable, Show) + +instance Exception ExpectedFailure + +expectedFailure :: MonadIO m => String -> m () +expectedFailure = liftIO . throwIO . ExpectedFailure diff --git a/packages/network-transport-tcp/tests/TestTCP.hs b/packages/network-transport-tcp/tests/TestTCP.hs new file mode 100644 index 00000000..1bbcd827 --- /dev/null +++ b/packages/network-transport-tcp/tests/TestTCP.hs @@ -0,0 +1,1147 @@ +{-# LANGUAGE RebindableSyntax, TemplateHaskell #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Main where + +import Prelude hiding + ( (>>=) + , return + , fail + , (>>) + ) +import Network.Transport +import Network.Transport.TCP ( createTransport + , createTransportExposeInternals + , TransportInternals(..) + , TCPParameters(..) + , defaultTCPParameters + , LightweightConnectionId + , TCPAddrInfo(..) + , TCPAddr(..) + , defaultTCPAddr + ) +import Control.Concurrent (threadDelay, killThread) +import Control.Concurrent.MVar ( MVar + , newEmptyMVar + , putMVar + , takeMVar + , readMVar + , isEmptyMVar + , newMVar + , modifyMVar + , modifyMVar_ + , swapMVar + ) +import Control.Monad (replicateM, guard, forM_, replicateM_, when) +import Control.Applicative ((<$>)) +import Control.Exception (throwIO, try, SomeException) +import Network.Transport.TCP ( socketToEndPoint ) +import Network.Transport.Internal ( prependLength + , tlog + , tryIO + , void + ) +import Network.Transport.TCP.Internal + ( ControlHeader(..) + , encodeControlHeader + , decodeControlHeader + , ConnectionRequestResponse(..) + , encodeConnectionRequestResponse + , decodeConnectionRequestResponse + , encodeWord32 + , recvWord32 + , forkServer + , recvWithLength + , encodeEndPointAddress + , decodeEndPointAddress + ) + +#ifdef USE_MOCK_NETWORK +import qualified Network.Transport.TCP.Mock.Socket as N +#else +import qualified Network.Socket as N +#endif + ( close + , ServiceName + , Socket + , AddrInfo + , shutdown + , ShutdownCmd(ShutdownSend) + , SockAddr(..) + , SocketType(Stream) + , AddrInfo(..) + , getAddrInfo + , defaultHints + , defaultProtocol + , socket + , connect + , close + ) + +#ifdef USE_MOCK_NETWORK +import Network.Transport.TCP.Mock.Socket.ByteString (sendMany) +#else +import Network.Socket.ByteString (sendMany) +#endif + +import qualified Data.ByteString as BS (length, concat) +import Data.String (fromString) +import GHC.IO.Exception (ioe_errno) +import Foreign.C.Error (Errno(..), eADDRNOTAVAIL) +import System.Timeout (timeout) +import Network.Transport.Tests (testTransportWithFilter) +import Network.Transport.Tests.Auxiliary (forkTry, runTests) +import Network.Transport.Tests.Traced + +instance Traceable ControlHeader where + trace = traceShow + +instance Traceable ConnectionRequestResponse where + trace = traceShow + +instance Traceable N.Socket where + trace = traceShow + +instance Traceable N.AddrInfo where + trace = traceShow + +instance Traceable TransportInternals where + trace = const Nothing + +-- Test that the server gets a ConnectionClosed message when the client closes +-- the socket without sending an explicit control message to the server first +testEarlyDisconnect :: IO () +testEarlyDisconnect = do + clientAddr <- newEmptyMVar + serverAddr <- newEmptyMVar + serverDone <- newEmptyMVar + + tlog "testEarlyDisconnect" + forkTry $ server serverAddr clientAddr serverDone + forkTry $ client serverAddr clientAddr + + takeMVar serverDone + where + server :: MVar EndPointAddress -> MVar EndPointAddress -> MVar () -> IO () + server serverAddr clientAddr serverDone = do + tlog "Server" + Right transport <- createTransport (defaultTCPAddr "127.0.0.1" "0") defaultTCPParameters + Right endpoint <- newEndPoint transport + putMVar serverAddr (address endpoint) + theirAddr <- readMVar clientAddr + + -- TEST 1: they connect to us, then drop the connection + do + ConnectionOpened _ _ addr <- receive endpoint + True <- return $ addr == theirAddr + + ErrorEvent (TransportError (EventConnectionLost addr') _) <- receive endpoint + True <- return $ addr' == theirAddr + + return () + + -- TEST 2: after they dropped their connection to us, we now try to + -- establish a connection to them. This should re-establish the broken + -- TCP connection. + tlog "Trying to connect to client" + Right conn <- connect endpoint theirAddr ReliableOrdered defaultConnectHints + + -- TEST 3: To test the connection, we do a simple ping test; as before, + -- however, the remote client won't close the connection nicely but just + -- closes the socket + do + Right () <- send conn ["ping"] + + ConnectionOpened cid _ addr <- receive endpoint + True <- return $ addr == theirAddr + + Received cid' ["pong"] <- receive endpoint + True <- return $ cid == cid' + + ErrorEvent (TransportError (EventConnectionLost addr') _) <- receive endpoint + True <- return $ addr' == theirAddr + + return () + + -- TEST 4: A subsequent send on an already-open connection will now break + Left (TransportError SendFailed _) <- send conn ["ping2"] + + -- *Pfew* + putMVar serverDone () + + client :: MVar EndPointAddress -> MVar EndPointAddress -> IO () + client serverAddr clientAddr = do + tlog "Client" + + -- Listen for incoming messages + (clientPort, _) <- forkServer "127.0.0.1" "0" 5 True throwIO throwIO $ \socketFree (sock, _) -> do + -- Initial setup + 0 <- recvWord32 sock + _ <- recvWithLength maxBound sock + sendMany sock [encodeWord32 (encodeConnectionRequestResponse ConnectionRequestAccepted)] + + -- Server opens a logical connection + Just CreatedNewConnection <- decodeControlHeader <$> recvWord32 sock + 1024 <- recvWord32 sock :: IO LightweightConnectionId + + -- Server sends a message + 1024 <- recvWord32 sock + ["ping"] <- recvWithLength maxBound sock + + -- Reply + sendMany sock [ + encodeWord32 (encodeControlHeader CreatedNewConnection) + , encodeWord32 10002 + ] + sendMany sock (encodeWord32 10002 : prependLength ["pong"]) + + -- Close the socket + N.close sock + + let ourAddress = encodeEndPointAddress "127.0.0.1" clientPort 0 + putMVar clientAddr ourAddress + + -- Connect to the server + Right (_, sock, ConnectionRequestAccepted) <- readMVar serverAddr >>= \addr -> socketToEndPoint (Just ourAddress) addr True False False Nothing Nothing + + -- Open a new connection + sendMany sock [ + encodeWord32 (encodeControlHeader CreatedNewConnection) + , encodeWord32 10003 + ] + + -- Close the socket without closing the connection explicitly + -- The server should receive an error event + N.close sock + +-- | Test the behaviour of a premature CloseSocket request +testEarlyCloseSocket :: IO () +testEarlyCloseSocket = do + clientAddr <- newEmptyMVar + serverAddr <- newEmptyMVar + serverDone <- newEmptyMVar + + tlog "testEarlyDisconnect" + forkTry $ server serverAddr clientAddr serverDone + forkTry $ client serverAddr clientAddr + + takeMVar serverDone + where + server :: MVar EndPointAddress -> MVar EndPointAddress -> MVar () -> IO () + server serverAddr clientAddr serverDone = do + tlog "Server" + Right transport <- createTransport (defaultTCPAddr "127.0.0.1" "0") defaultTCPParameters + Right endpoint <- newEndPoint transport + putMVar serverAddr (address endpoint) + theirAddr <- readMVar clientAddr + + -- TEST 1: they connect to us, then send a CloseSocket. Since we don't + -- have any outgoing connections, this means we will agree to close the + -- socket + do + ConnectionOpened cid _ addr <- receive endpoint + True <- return $ addr == theirAddr + + ConnectionClosed cid' <- receive endpoint + True <- return $ cid' == cid + + return () + + -- TEST 2: after they dropped their connection to us, we now try to + -- establish a connection to them. This should re-establish the broken + -- TCP connection. + tlog "Trying to connect to client" + Right conn <- connect endpoint theirAddr ReliableOrdered defaultConnectHints + + -- TEST 3: To test the connection, we do a simple ping test; as before, + -- however, the remote client won't close the connection nicely but just + -- sends a CloseSocket -- except that now we *do* have outgoing + -- connections, so we won't agree and hence will receive an error when + -- the socket gets closed + do + Right () <- send conn ["ping"] + + ConnectionOpened cid _ addr <- receive endpoint + True <- return $ addr == theirAddr + + Received cid' ["pong"] <- receive endpoint + True <- return $ cid' == cid + + ConnectionClosed cid'' <- receive endpoint + True <- return $ cid'' == cid + + ErrorEvent (TransportError (EventConnectionLost addr') _) <- receive endpoint + True <- return $ addr' == theirAddr + + return () + + -- TEST 4: A subsequent send on an already-open connection will now break + Left (TransportError SendFailed _) <- send conn ["ping2"] + + -- *Pfew* + putMVar serverDone () + + client :: MVar EndPointAddress -> MVar EndPointAddress -> IO () + client serverAddr clientAddr = do + tlog "Client" + + -- Listen for incoming messages + (clientPort, _) <- forkServer "127.0.0.1" "0" 5 True throwIO throwIO $ \socketFree (sock, _) -> do + -- Initial setup + 0 <- recvWord32 sock + _ <- recvWithLength maxBound sock + sendMany sock [encodeWord32 (encodeConnectionRequestResponse ConnectionRequestAccepted)] + + -- Server opens a logical connection + Just CreatedNewConnection <- decodeControlHeader <$> recvWord32 sock + 1024 <- recvWord32 sock :: IO LightweightConnectionId + + -- Server sends a message + 1024 <- recvWord32 sock + ["ping"] <- recvWithLength maxBound sock + + -- Reply + sendMany sock [ + encodeWord32 (encodeControlHeader CreatedNewConnection) + , encodeWord32 10002 + ] + sendMany sock (encodeWord32 10002 : prependLength ["pong"]) + + -- Send a CloseSocket even though there are still connections *in both + -- directions* + sendMany sock [ + encodeWord32 (encodeControlHeader CloseSocket) + , encodeWord32 1024 + ] + N.close sock + + let ourAddress = encodeEndPointAddress "127.0.0.1" clientPort 0 + putMVar clientAddr ourAddress + + -- Connect to the server + Right (_, sock, ConnectionRequestAccepted) <- readMVar serverAddr >>= \addr -> socketToEndPoint (Just ourAddress) addr True False False Nothing Nothing + + -- Open a new connection + sendMany sock [ + encodeWord32 (encodeControlHeader CreatedNewConnection) + , encodeWord32 10003 + ] + + -- Send a CloseSocket without sending a closeconnecton + -- The server should still receive a ConnectionClosed message + sendMany sock [ + encodeWord32 (encodeControlHeader CloseSocket) + , encodeWord32 0 + ] + N.close sock + +-- | Test the creation of a transport with an invalid address +testInvalidAddress :: IO () +testInvalidAddress = do + Left _ <- createTransport (defaultTCPAddr "invalidHostName" "0") defaultTCPParameters + return () + +-- | Test connecting to invalid or non-existing endpoints +testInvalidConnect :: IO () +testInvalidConnect = do + Right transport <- createTransport (defaultTCPAddr "127.0.0.1" "0") defaultTCPParameters + Right endpoint <- newEndPoint transport + + -- Syntax error in the endpoint address + Left (TransportError ConnectFailed _) <- + connect endpoint (EndPointAddress "InvalidAddress") ReliableOrdered defaultConnectHints + + -- Syntax connect, but invalid hostname (TCP address lookup failure) + Left (TransportError ConnectNotFound _) <- + connect endpoint (encodeEndPointAddress "invalidHost" "port" 0) ReliableOrdered defaultConnectHints + + -- TCP address correct, but nobody home at that address + Left (TransportError ConnectNotFound _) <- + connect endpoint (encodeEndPointAddress "127.0.0.1" "9000" 0) ReliableOrdered defaultConnectHints + + -- Valid TCP address but invalid endpoint number + Left (TransportError ConnectNotFound _) <- + connect endpoint (encodeEndPointAddress "127.0.0.1" "0" 1) ReliableOrdered defaultConnectHints + + return () + +-- | Test that an endpoint can ignore CloseSocket requests (in "reality" this +-- would happen when the endpoint sends a new connection request before +-- receiving an (already underway) CloseSocket request) +testIgnoreCloseSocket :: IO () +testIgnoreCloseSocket = do + serverAddr <- newEmptyMVar + clientAddr <- newEmptyMVar + clientDone <- newEmptyMVar + serverDone <- newEmptyMVar + connectionEstablished <- newEmptyMVar + Right transport <- createTransport (defaultTCPAddr "127.0.0.1" "0") defaultTCPParameters + + -- Server + forkTry $ do + tlog "Server" + Right endpoint <- newEndPoint transport + putMVar serverAddr (address endpoint) + + let ourAddress = address endpoint + theirAddress <- readMVar clientAddr + + -- Wait for the client to set up the TCP connection to us + takeMVar connectionEstablished + + -- Connect then disconnect to the client + Right conn <- connect endpoint theirAddress ReliableOrdered defaultConnectHints + close conn + + -- At this point the server will have sent a CloseSocket request to the + -- client, which however ignores it, instead it requests and closes + -- another connection + tlog "Waiting for ConnectionOpened" + ConnectionOpened _ _ _ <- receive endpoint + tlog "Waiting for ConnectionClosed" + ConnectionClosed _ <- receive endpoint + + putMVar serverDone () + + -- Client + forkTry $ do + tlog "Client" + Right endpoint <- newEndPoint transport + putMVar clientAddr (address endpoint) + + let ourAddress = address endpoint + theirAddress <- readMVar serverAddr + + -- Connect to the server + Right (_, sock, ConnectionRequestAccepted) <- socketToEndPoint (Just ourAddress) theirAddress True False False Nothing Nothing + putMVar connectionEstablished () + + -- Server connects to us, and then closes the connection + Just CreatedNewConnection <- decodeControlHeader <$> recvWord32 sock + 1024 <- recvWord32 sock :: IO LightweightConnectionId + + Just CloseConnection <- decodeControlHeader <$> recvWord32 sock + 1024 <- recvWord32 sock :: IO LightweightConnectionId + + -- Server will now send a CloseSocket request as its refcount reached 0 + tlog "Waiting for CloseSocket request" + Just CloseSocket <- decodeControlHeader <$> recvWord32 sock + _ <- recvWord32 sock :: IO LightweightConnectionId + + -- But we ignore it and request another connection in the other direction + tlog "Ignoring it, requesting another connection" + sendMany sock [ + encodeWord32 (encodeControlHeader CreatedNewConnection) + , encodeWord32 1024 + ] + + -- Close it again + tlog "Closing connection" + sendMany sock [ + encodeWord32 (encodeControlHeader CloseConnection) + , encodeWord32 1024 + ] + + -- And close the connection completely + tlog "Closing socket" + sendMany sock [ + encodeWord32 (encodeControlHeader CloseSocket) + , encodeWord32 1024 + ] + N.close sock + + putMVar clientDone () + + takeMVar clientDone + takeMVar serverDone + +-- | Like 'testIgnoreSocket', but now the server requests a connection after the +-- client closed their connection. In the meantime, the server will have sent a +-- CloseSocket request to the client, and must block until the client responds. +testBlockAfterCloseSocket :: IO () +testBlockAfterCloseSocket = do + serverAddr <- newEmptyMVar + clientAddr <- newEmptyMVar + clientDone <- newEmptyMVar + serverDone <- newEmptyMVar + connectionEstablished <- newEmptyMVar + Right transport <- createTransport (defaultTCPAddr "127.0.0.1" "0") defaultTCPParameters + + -- Server + forkTry $ do + tlog "Server" + Right endpoint <- newEndPoint transport + putMVar serverAddr (address endpoint) + + let ourAddress = address endpoint + theirAddress <- readMVar clientAddr + + -- Wait for the client to set up the TCP connection to us + takeMVar connectionEstablished + + -- Connect then disconnect to the client + Right conn <- connect endpoint theirAddress ReliableOrdered defaultConnectHints + close conn + + -- At this point the server will have sent a CloseSocket request to the + -- client, and must block until the client responds + Right conn <- connect endpoint theirAddress ReliableOrdered defaultConnectHints + + putMVar serverDone () + + -- Client + forkTry $ do + tlog "Client" + Right endpoint <- newEndPoint transport + putMVar clientAddr (address endpoint) + + let ourAddress = address endpoint + theirAddress <- readMVar serverAddr + + -- Connect to the server + Right (_, sock, ConnectionRequestAccepted) <- socketToEndPoint (Just ourAddress) theirAddress True False False Nothing Nothing + putMVar connectionEstablished () + + -- Server connects to us, and then closes the connection + Just CreatedNewConnection <- decodeControlHeader <$> recvWord32 sock + 1024 <- recvWord32 sock :: IO LightweightConnectionId + + Just CloseConnection <- decodeControlHeader <$> recvWord32 sock + 1024 <- recvWord32 sock :: IO LightweightConnectionId + + -- Server will now send a CloseSocket request as its refcount reached 0 + tlog "Waiting for CloseSocket request" + Just CloseSocket <- decodeControlHeader <$> recvWord32 sock + _ <- recvWord32 sock :: IO LightweightConnectionId + + unblocked <- newMVar False + + -- We should not hear from the server until we unblock him by + -- responding to the CloseSocket request (in this case, we + -- respond by sending a ConnectionRequest) + forkTry $ do + recvWord32 sock + readMVar unblocked >>= guard + putMVar clientDone () + + threadDelay 1000000 + + tlog "Client ignores close socket and sends connection request" + tlog "This should unblock the server" + modifyMVar_ unblocked $ \_ -> return True + sendMany sock [ + encodeWord32 (encodeControlHeader CreatedNewConnection) + , encodeWord32 1024 + ] + + takeMVar clientDone + takeMVar serverDone + +-- | Test what happens when a remote endpoint sends a connection request to our +-- transport for an endpoint it already has a connection to +testUnnecessaryConnect :: Int -> IO () +testUnnecessaryConnect numThreads = do + clientDone <- newEmptyMVar + serverAddr <- newEmptyMVar + + forkTry $ do + Right transport <- createTransport (defaultTCPAddr "127.0.0.1" "0") defaultTCPParameters + Right endpoint <- newEndPoint transport + -- Since we're lying about the server's address, we have to manually + -- construct the proper address. If we used its actual address, the clients + -- would try to resolve "128.0.0.1" and then would fail due to invalid + -- address. + Just (_, port, epid) <- return $ decodeEndPointAddress (address endpoint) + putMVar serverAddr $ encodeEndPointAddress "127.0.0.1" port epid + + forkTry $ do + -- We pick an address < 128.0.0.1 so that this is not rejected purely because of the "crossed" check + let ourAddress = encodeEndPointAddress "127.0.0.1" "1234" 0 + + -- We should only get a single 'Accepted' reply + gotAccepted <- newEmptyMVar + dones <- replicateM numThreads $ do + done <- newEmptyMVar + forkTry $ do + -- It is possible that the remote endpoint just rejects the request by closing the socket + -- immediately (depending on far the remote endpoint got with the initialization) + response <- readMVar serverAddr >>= \addr -> socketToEndPoint (Just ourAddress) addr True False False Nothing Nothing + case response of + Right (_, _, ConnectionRequestAccepted) -> + -- We don't close this socket because we want to keep this connection open + putMVar gotAccepted () + -- We might get either Invalid or Crossed (the transport does not + -- maintain enough history to be able to tell) + Right (_, sock, ConnectionRequestInvalid) -> + N.close sock + Right (_, sock, ConnectionRequestCrossed) -> + N.close sock + Left _ -> + return () + putMVar done () + return done + + mapM_ readMVar (gotAccepted : dones) + putMVar clientDone () + + takeMVar clientDone + +-- | Test that we can create "many" transport instances +testMany :: IO () +testMany = do + Right masterTransport <- createTransport (defaultTCPAddr "127.0.0.1" "0") defaultTCPParameters + Right masterEndPoint <- newEndPoint masterTransport + + replicateM_ 10 $ do + mTransport <- createTransport (defaultTCPAddr "127.0.0.1" "0") defaultTCPParameters + case mTransport of + Left ex -> do + putStrLn $ "IOException: " ++ show ex ++ "; errno = " ++ show (ioe_errno ex) + case (ioe_errno ex) of + Just no | Errno no == eADDRNOTAVAIL -> putStrLn "(ADDRNOTAVAIL)" + _ -> return () + throwIO ex + Right transport -> + replicateM_ 2 $ do + Right endpoint <- newEndPoint transport + Right _ <- connect endpoint (address masterEndPoint) ReliableOrdered defaultConnectHints + return () + +-- | Test what happens when the transport breaks completely +testBreakTransport :: IO () +testBreakTransport = do + Right (transport, internals) <- createTransportExposeInternals (defaultTCPAddr "127.0.0.1" "0") defaultTCPParameters + Right endpoint <- newEndPoint transport + + let Just tid = transportThread internals + killThread tid -- Uh oh + + ErrorEvent (TransportError EventTransportFailed _) <- receive endpoint + + return () + +-- Used in testReconnect to block until a socket is closed. newtype is needed +-- for the Traceable instance. +newtype WaitSocketFree = WaitSocketFree (IO ()) + +instance Traceable WaitSocketFree where + trace = const Nothing + +-- | Test that a second call to 'connect' might succeed even if the first +-- failed. This is a TCP specific test rather than an endpoint specific test +-- because we must manually create the endpoint address to match an endpoint we +-- have yet to set up. +-- Then test that we get a connection lost message after the remote endpoint +-- suddenly closes the socket, and that a subsequent 'connect' allows us to +-- re-establish a connection to the same endpoint +testReconnect :: IO () +testReconnect = do + serverDone <- newEmptyMVar + endpointCreated <- newEmptyMVar + -- The server will put the 'socketFree' IO in here, so that the client can + -- block until the server has closed the socket. + socketClosed <- newEmptyMVar + + counter <- newMVar (0 :: Int) + + -- Server + (serverPort, _) <- forkServer "127.0.0.1" "0" 5 True throwIO throwIO $ \socketFree (sock, _) -> do + -- Accept the connection + Right 0 <- tryIO $ recvWord32 sock + Right _ <- tryIO $ recvWithLength maxBound sock + + -- The first time we close the socket before accepting the logical connection + count <- modifyMVar counter $ \i -> return (i + 1, i) + + -- Wait 100ms after the socket closes, to (hopefully) ensure that the client + -- knows the connection is closed, and sending on that socket will therefore + -- fail. + putMVar socketClosed (WaitSocketFree (socketFree >> threadDelay 100000)) + + when (count > 0) $ do + -- The second, third, and fourth connections are accepted according to the + -- protocol. + -- On the second request, the socket then closes. + Right () <- tryIO $ sendMany sock [ + encodeWord32 (encodeConnectionRequestResponse ConnectionRequestAccepted) + ] + -- Client requests a logical connection + when (count > 1) $ do + -- On the third and fourth requests, a new logical connection is + -- accepted. + -- On the third request the socket then closes. + Right (Just CreatedNewConnection) <- tryIO $ decodeControlHeader <$> recvWord32 sock + connId <- recvWord32 sock :: IO LightweightConnectionId + + when (count > 2) $ do + -- On the fourth request, a message is received and then the socket + -- is closed. + Right connId' <- tryIO $ (recvWord32 sock :: IO LightweightConnectionId) + True <- return $ connId == connId' + Right ["ping"] <- tryIO $ recvWithLength maxBound sock + putMVar serverDone () + + return () + + putMVar endpointCreated () + + -- Client + forkTry $ do + Right transport <- createTransport (defaultTCPAddr "127.0.0.1" "0") defaultTCPParameters + Right endpoint <- newEndPoint transport + let theirAddr = encodeEndPointAddress "127.0.0.1" serverPort 0 + + takeMVar endpointCreated + + -- First attempt: fails because the server closes the socket without + -- doing the handshake. + resultConnect <- connect endpoint theirAddr ReliableOrdered defaultConnectHints + case resultConnect of + Left (TransportError ConnectFailed _) -> return () + Left err -> throwIO err + Right _ -> throwIO $ userError "testConnect: unexpected connect success" + WaitSocketFree wait <- takeMVar socketClosed + wait + + -- Second attempt: server accepts the connection but then closes the socket. + -- We expect a failed connection if the socket is closed *before* + -- CreatedNewConnection is sent, or a successful connection such that a + -- subsequent send will fail in case CreatedNewConnection was sent before + -- the close. + resultConnect <- connect endpoint theirAddr ReliableOrdered defaultConnectHints + -- We must be sure that the socket has closed before trying to send. + WaitSocketFree wait <- takeMVar socketClosed + wait + case resultConnect of + Left (TransportError ConnectFailed _) -> return () + Left err -> throwIO err + Right c -> do + ev <- send c ["ping"] + case ev of + Left _ -> return () + Right _ -> throwIO $ userError "testConnect: unexpected send success" + + -- In any case, since a heavyweight connection was made, we'll get a + -- connection lost event. + ErrorEvent (TransportError (EventConnectionLost _) _) <- receive endpoint + + -- Third attempt: server accepts the heavyweight and the lightweight + -- connection (CreatedNewConnection) but then closes the socket. + -- The connection must succeed, but sending after the socket is closed + -- must fail. + resultConnect <- connect endpoint theirAddr ReliableOrdered defaultConnectHints + -- Wait until close before trying to send. + WaitSocketFree wait <- takeMVar socketClosed + wait + case resultConnect of + Left err -> throwIO err + Right c -> do + ev <- send c ["ping"] + case ev of + Left (TransportError SendFailed _) -> return () + Left err -> throwIO err + Right _ -> throwIO $ userError "testConnect: unexpected send success" + + ErrorEvent (TransportError (EventConnectionLost _) _) <- receive endpoint + + -- But a subsequent call to connect should reestablish the connection + Right conn2 <- connect endpoint theirAddr ReliableOrdered defaultConnectHints + + -- Send should now succeed + Right () <- send conn2 ["ping"] + + WaitSocketFree wait <- takeMVar socketClosed + wait + return () + + takeMVar serverDone + +-- Test what happens if we close the socket one way only. This means that the +-- 'recv' in 'handleIncomingMessages' will not fail, but a 'send' or 'connect' +-- *will* fail. We are testing that error handling everywhere does the right +-- thing. +testUnidirectionalError :: IO () +testUnidirectionalError = do + clientDone <- newEmptyMVar + serverGotPing <- newEmptyMVar + + -- Server + (serverPort, _) <- forkServer "127.0.0.1" "0" 5 True throwIO throwIO $ \socketFree (sock, _) -> do + -- We accept connections, but when an exception occurs we don't do + -- anything (in particular, we don't close the socket). This is important + -- because when we shutdown one direction of the socket a recv here will + -- fail, but we don't want to close that socket at that point (which + -- would shutdown the socket in the other direction) + void . (try :: IO () -> IO (Either SomeException ())) $ do + 0 <- recvWord32 sock + _ <- recvWithLength maxBound sock + () <- sendMany sock [encodeWord32 (encodeConnectionRequestResponse ConnectionRequestAccepted)] + + Just CreatedNewConnection <- decodeControlHeader <$> recvWord32 sock + connId <- recvWord32 sock :: IO LightweightConnectionId + + connId' <- recvWord32 sock :: IO LightweightConnectionId + True <- return $ connId == connId' + ["ping"] <- recvWithLength maxBound sock + putMVar serverGotPing () + + -- Must read the clientDone MVar so that we don't close the socket + -- (forkServer will close it once this action ends). + readMVar clientDone + + -- Client + forkTry $ do + Right (transport, internals) <- createTransportExposeInternals (defaultTCPAddr "127.0.0.1" "0") defaultTCPParameters + Right endpoint <- newEndPoint transport + let theirAddr = encodeEndPointAddress "127.0.0.1" serverPort 0 + + -- Establish a connection to the server + Right conn1 <- connect endpoint theirAddr ReliableOrdered defaultConnectHints + send conn1 ["ping"] + takeMVar serverGotPing + + -- Close the *outgoing* part of the socket only + sock <- socketBetween internals (address endpoint) theirAddr + N.shutdown sock N.ShutdownSend + + -- At this point we cannot notice the problem yet so we shouldn't receive an event yet + Nothing <- timeout 500000 $ receive endpoint + + -- But when we send we find the error + Left (TransportError SendFailed _) <- send conn1 ["ping"] + ErrorEvent (TransportError (EventConnectionLost _) _) <- receive endpoint + + -- A call to connect should now re-establish the connection + Right conn2 <- connect endpoint theirAddr ReliableOrdered defaultConnectHints + send conn2 ["ping"] + takeMVar serverGotPing + + -- Again, close the outgoing part of the socket + sock' <- socketBetween internals (address endpoint) theirAddr + N.shutdown sock' N.ShutdownSend + + -- We now find the error when we attempt to close the connection + Nothing <- timeout 500000 $ receive endpoint + close conn2 + ErrorEvent (TransportError (EventConnectionLost _) _) <- receive endpoint + Right conn3 <- connect endpoint theirAddr ReliableOrdered defaultConnectHints + send conn3 ["ping"] + takeMVar serverGotPing + + -- We repeat once more. + sock'' <- socketBetween internals (address endpoint) theirAddr + N.shutdown sock'' N.ShutdownSend + + -- Now we notice the problem when we try to connect + Nothing <- timeout 500000 $ receive endpoint + Left (TransportError ConnectFailed _) <- connect endpoint theirAddr ReliableOrdered defaultConnectHints + ErrorEvent (TransportError (EventConnectionLost _) _) <- receive endpoint + Right conn4 <- connect endpoint theirAddr ReliableOrdered defaultConnectHints + send conn4 ["ping"] + takeMVar serverGotPing + + putMVar clientDone () + + readMVar clientDone + +testInvalidCloseConnection :: IO () +testInvalidCloseConnection = do + Right (transport, internals) <- createTransportExposeInternals (defaultTCPAddr "127.0.0.1" "0") defaultTCPParameters + serverAddr <- newEmptyMVar + clientDone <- newEmptyMVar + serverDone <- newEmptyMVar + + -- Server + forkTry $ do + Right endpoint <- newEndPoint transport + putMVar serverAddr (address endpoint) + + ConnectionOpened _ _ _ <- receive endpoint + + -- At this point the client sends an invalid request, so we terminate the + -- connection + ErrorEvent (TransportError (EventConnectionLost _) _) <- receive endpoint + + putMVar serverDone () + + -- Client + forkTry $ do + Right endpoint <- newEndPoint transport + let ourAddr = address endpoint + + -- Connect so that we have a TCP connection + theirAddr <- readMVar serverAddr + Right _ <- connect endpoint theirAddr ReliableOrdered defaultConnectHints + + -- Get a handle on the TCP connection and manually send an invalid CloseConnection request + sock <- socketBetween internals ourAddr theirAddr + sendMany sock [ + encodeWord32 (encodeControlHeader CloseConnection) + , encodeWord32 (12345 :: LightweightConnectionId) + ] + + putMVar clientDone () + + mapM_ takeMVar [clientDone, serverDone] + +testUseRandomPort :: IO () +testUseRandomPort = do + testDone <- newEmptyMVar + forkTry $ do + Right transport1 <- createTransport (defaultTCPAddr "127.0.0.1" "0") defaultTCPParameters + Right ep1 <- newEndPoint transport1 + -- Same as transport1, but is strict in the port. + Right transport2 <- createTransport (Addressable (TCPAddrInfo "127.0.0.1" "0" (\(!port) -> ("127.0.0.1", port)))) defaultTCPParameters + Right ep2 <- newEndPoint transport2 + Right conn1 <- connect ep2 (address ep1) ReliableOrdered defaultConnectHints + ConnectionOpened _ _ _ <- receive ep1 + putMVar testDone () + takeMVar testDone + +-- | Verify that if a peer sends an address or data which exceeds the maximum +-- length, that peer's connection will be terminated, but other peers will +-- not be affected. +testMaxLength :: IO () +testMaxLength = do + + Right serverTransport <- createTransport (defaultTCPAddr "127.0.0.1" "9998") $ defaultTCPParameters { + -- 17 bytes should fit every valid address at 127.0.0.1. + -- Port is at most 5 bytes (65536) and id is a base-10 Word32 so + -- at most 10 bytes. We'll have one client with a 5-byte port to push it + -- over the chosen limit of 16 + tcpMaxAddressLength = 16 + , tcpMaxReceiveLength = 8 + } + Right goodClientTransport <- createTransport (defaultTCPAddr "127.0.0.1" "9999") defaultTCPParameters + Right badClientTransport <- createTransport (defaultTCPAddr "127.0.0.1" "10000") defaultTCPParameters + + serverAddress <- newEmptyMVar + testDone <- newEmptyMVar + goodClientConnected <- newEmptyMVar + goodClientDone <- newEmptyMVar + badClientDone <- newEmptyMVar + + forkTry $ do + Right serverEp <- newEndPoint serverTransport + putMVar serverAddress (address serverEp) + readMVar badClientDone + ConnectionOpened _ _ _ <- receive serverEp + Received _ _ <- receive serverEp + -- Will lose the connection when the good client sends 9 bytes. + ErrorEvent (TransportError (EventConnectionLost _) _) <- receive serverEp + readMVar goodClientDone + putMVar testDone () + + forkTry $ do + Right badClientEp <- newEndPoint badClientTransport + address <- readMVar serverAddress + -- Wait until the good client connects, then try to connect. It'll fail, + -- but the good client should still be OK. + readMVar goodClientConnected + Left (TransportError ConnectFailed _) + <- connect badClientEp address ReliableOrdered defaultConnectHints + closeEndPoint badClientEp + putMVar badClientDone () + + forkTry $ do + Right goodClientEp <- newEndPoint goodClientTransport + address <- readMVar serverAddress + Right conn <- connect goodClientEp address ReliableOrdered defaultConnectHints + putMVar goodClientConnected () + -- Wait until the bad client has tried and failed to connect before + -- attempting a send, to ensure that its failure did not affect us. + readMVar badClientDone + Right () <- send conn ["00000000"] + -- The send which breaches the limit does not appear to fail, but the + -- (heavyweight) connection is now severed. We can reliably determine that + -- by receiving. + Right () <- send conn ["000000000"] + ErrorEvent (TransportError (EventConnectionLost _) _) <- receive goodClientEp + closeEndPoint goodClientEp + putMVar goodClientDone () + + readMVar testDone + closeTransport badClientTransport + closeTransport goodClientTransport + closeTransport serverTransport + +-- | Ensure that an end point closes up OK even if the peer disobeys the +-- protocol. +testCloseEndPoint :: IO () +testCloseEndPoint = do + + serverAddress <- newEmptyMVar + serverFinished <- newEmptyMVar + + -- A server which accepts one connection and then attempts to close the + -- end point. + forkTry $ do + Right transport <- createTransport (defaultTCPAddr "127.0.0.1" "0") defaultTCPParameters + Right ep <- newEndPoint transport + putMVar serverAddress (address ep) + ConnectionOpened _ _ _ <- receive ep + Just () <- timeout 5000000 (closeEndPoint ep) + putMVar serverFinished () + return () + + -- A nefarious client which connects to the server then stops responding. + forkTry $ do + Just (hostName, serviceName, endPointId) <- decodeEndPointAddress <$> readMVar serverAddress + addr:_ <- N.getAddrInfo (Just N.defaultHints) (Just hostName) (Just serviceName) + sock <- N.socket (N.addrFamily addr) N.Stream N.defaultProtocol + N.connect sock (N.addrAddress addr) + let endPointAddress = "127.0.0.1:0:0" + -- Version 0x00000000 handshake data. + v0handshake = [ + encodeWord32 endPointId + , encodeWord32 (fromIntegral (BS.length endPointAddress)) + , endPointAddress + ] + -- Version, and total length of the versioned handshake. + handshake = [ + encodeWord32 0x00000000 + , encodeWord32 (fromIntegral (BS.length (BS.concat v0handshake))) + ] + sendMany sock $ + handshake + ++ v0handshake + ++ [ -- Create a lightweight connection. + encodeWord32 (encodeControlHeader CreatedNewConnection) + , encodeWord32 1024 + ] + readMVar serverFinished + N.close sock + + readMVar serverFinished + +-- | Ensure that if the peer's claimed host doesn't match its actual host, +-- the connection is rejected (when tcpCheckPeerHost is enabled). +testCheckPeerHostReject :: IO () +testCheckPeerHostReject = do + + let params = defaultTCPParameters { tcpCheckPeerHost = True } + Right transport1 <- createTransport (defaultTCPAddr "127.0.0.1" "0") params + -- This transport claims 127.0.0.2 as its host, but connections from it to + -- an EndPoint on transport1 will show 127.0.0.1 as the socket's source host. + Right transport2 <- createTransport (Addressable (TCPAddrInfo "127.0.0.1" "0" ((,) "127.0.0.2"))) defaultTCPParameters + + Right ep1 <- newEndPoint transport1 + Right ep2 <- newEndPoint transport2 + + Left err <- connect ep2 (address ep1) ReliableOrdered defaultConnectHints + + TransportError ConnectFailed _ <- return err + + return () + +-- | Ensure that if peer host checking works through name resolution: if the +-- peer claims "localhost", and connects to a transport also on localhost, +-- it should be accepted. +-- +-- This test fails on some systems which resolve to +-- "localhost.localdomain" instead of "localhost". Disabling it for +-- now. +testCheckPeerHostResolve :: IO () +testCheckPeerHostResolve = do + + let + params = defaultTCPParameters { tcpCheckPeerHost = True } + -- This test only passes with this choice on some systems + -- localHostName = "localhost.localdomain" + localHostName = "localhost" + Right transport1 <- createTransport (defaultTCPAddr "127.0.0.1" "0") params + -- EndPoints on this transport have addresses with "localhost" host part. + Right transport2 <- createTransport (Addressable (TCPAddrInfo "127.0.0.1" "0" ((,) localHostName))) defaultTCPParameters + + Right ep1 <- newEndPoint transport1 + Right ep2 <- newEndPoint transport2 + + Right conn <- connect ep2 (address ep1) ReliableOrdered defaultConnectHints + + close conn + + return () + +-- | Test that an unreachable EndPoint can use its own address to connect +-- to itself. +testUnreachableSelfConnect :: IO () +testUnreachableSelfConnect = do + Right transport <- createTransport Unaddressable defaultTCPParameters + Right ep <- newEndPoint transport + Right conn <- connect ep (address ep) ReliableOrdered defaultConnectHints + ConnectionOpened connid ReliableOrdered _ <- receive ep + Right () <- send conn ["ping"] + Received connid' bytes <- receive ep + _ <- close conn + ConnectionClosed connid'' <- receive ep + closeEndPoint ep + closeTransport transport + +-- | Test that +-- +-- 1. Connecting to an unreachable EndPoint's address gives ConnectFailed +-- 2. An unreachable EndPoint can successfully connect to a reachable EndPoint +-- 3. The address given in the ConnectionOpened event at the reachable EndPoint +-- can be used to connect to the unreachable EndPoint, so long as there is +-- at least one lightweight connection open between the two. +testUnreachableConnect :: IO () +testUnreachableConnect = do + Right rtransport <- createTransport (defaultTCPAddr "127.0.0.1" "0") defaultTCPParameters + Right utransport <- createTransport Unaddressable defaultTCPParameters + Right rep <- newEndPoint rtransport + Right uep <- newEndPoint utransport + -- Reachable endpoint connects to the unreachable endpoint, but it fails. + -- NB ConnectNotFound isn't the error; that would mean the address makes + -- sense but the host could not be found. + Left (TransportError ConnectFailed _) <- connect rep (address uep) ReliableOrdered defaultConnectHints + -- Unreachable endpoint connects to the reachable endpoint. + Right conn <- connect uep (address rep) ReliableOrdered defaultConnectHints + -- Reachable endpoint now has an address at which it can connect to the + -- unreachable + ConnectionOpened _ _ addr <- receive rep + Right conn' <- connect rep addr ReliableOrdered defaultConnectHints + ConnectionOpened _ _ addr' <- receive uep + close conn + ConnectionClosed _ <- receive rep + close conn' + ConnectionClosed _ <- receive uep + closeEndPoint rep + closeEndPoint uep + closeTransport rtransport + closeTransport utransport + +main :: IO () +main = do + tcpResult <- tryIO $ runTests + [ ("Use random port", testUseRandomPort) + , ("EarlyDisconnect", testEarlyDisconnect) + , ("EarlyCloseSocket", testEarlyCloseSocket) + , ("IgnoreCloseSocket", testIgnoreCloseSocket) + , ("BlockAfterCloseSocket", testBlockAfterCloseSocket) + -- , ("UnnecessaryConnect", testUnnecessaryConnect 10) -- flaky: #91 + , ("InvalidAddress", testInvalidAddress) + , ("InvalidConnect", testInvalidConnect) + , ("Many", testMany) + , ("BreakTransport", testBreakTransport) + , ("Reconnect", testReconnect) + , ("UnidirectionalError", testUnidirectionalError) + , ("InvalidCloseConnection", testInvalidCloseConnection) + , ("MaxLength", testMaxLength) + , ("CloseEndPoint", testCloseEndPoint) + , ("CheckPeerHostReject", testCheckPeerHostReject) + -- , ("CheckPeerHostResolve", testCheckPeerHostResolve) -- flaky + , ("UnreachableSelfConnect", testUnreachableSelfConnect) + , ("UnreachableConnect", testUnreachableConnect) + ] + -- Run the generic tests even if the TCP specific tests failed.. + testTransportWithFilter (`notElem` flakies) (either (Left . show) (Right) <$> + createTransport (defaultTCPAddr "127.0.0.1" "0") defaultTCPParameters) + -- ..but if the generic tests pass, still fail if the specific tests did not + case tcpResult of + Left err -> throwIO err + Right () -> return () + where + flakies = + [ "ParallelConnects" -- #92 + ] diff --git a/packages/network-transport-tests/ChangeLog b/packages/network-transport-tests/ChangeLog new file mode 100644 index 00000000..8a44fda6 --- /dev/null +++ b/packages/network-transport-tests/ChangeLog @@ -0,0 +1,50 @@ +2024-03-25 David Simmons-Duffin 0.3.2 + +* Update dependency bounds for ghc 9.8. + +2022-10-12 Facundo Domínguez 0.3.1 + +* Update dependency bounds for ghc 9. + +2020-10-09 Facundo Domínguez 0.3.0 + +* Added testTransportWithFilter to allow selecting which tests to run. + +2019-12-31 Facundo Domínguez 0.2.4.3 + +* Relaxed upper bound on containers. + +2016-10-05 Facundo Domínguez 0.2.4.2 + +* Remove upper bound for ansi-terminal. + +2016-08-21 Facundo Domínguez 0.2.4.1 + +* fix race in testCloseConnect + +2016-08-21 Facundo Domínguez 0.2.4.0 + +* Fix race in testCloseEndpoint +* Tests receive events eagerly +* Update upper bound of n-t +* Removed EndPointAddress equality checks + +2016-02-17 Facundo Domínguez 0.2.3.0 + +* Add a test for send strictness in self connections. + +2014-12-09 Tim Watson 0.2.1.0 + +* Dependencies bump + +2014-12-09 Tim Watson 0.2.0.0 + +* Dependencies bump + +2012-10-19 Edsko de Vries 0.1.0.1 + +* Change CloseTransport test + +2012-10-03 Edsko de Vries 0.1.0 + +* Initial release (these tests used to be part of the individual transports) diff --git a/packages/network-transport-tests/LICENSE b/packages/network-transport-tests/LICENSE new file mode 100644 index 00000000..7a956d0d --- /dev/null +++ b/packages/network-transport-tests/LICENSE @@ -0,0 +1,30 @@ +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. diff --git a/Setup.hs b/packages/network-transport-tests/Setup.hs similarity index 100% rename from Setup.hs rename to packages/network-transport-tests/Setup.hs diff --git a/packages/network-transport-tests/network-transport-tests.cabal b/packages/network-transport-tests/network-transport-tests.cabal new file mode 100644 index 00000000..0561218b --- /dev/null +++ b/packages/network-transport-tests/network-transport-tests.cabal @@ -0,0 +1,52 @@ +cabal-version: 3.0 +name: network-transport-tests +version: 0.3.2 +synopsis: Unit tests for Network.Transport implementations +-- description: +homepage: http://haskell-distributed.github.com +license: BSD-3-Clause +license-file: LICENSE +author: Edsko de Vries +maintainer: The Distributed Haskell team +copyright: Well-Typed LLP +category: Network +build-type: Simple + +Source-Repository head + Type: git + Location: https://github.com/haskell-distributed/network-transport-tests + +common warnings + ghc-options: -Wall + -Wcompat + -Widentities + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wredundant-constraints + -fhide-source-paths + -Wpartial-fields + +library + import: warnings + exposed-modules: Network.Transport.Tests, + Network.Transport.Tests.Multicast, + Network.Transport.Tests.Auxiliary, + Network.Transport.Tests.Traced + -- other-modules: + build-depends: base >= 4.14 && < 5, + network-transport >= 0.4.1.0 && < 0.6, + containers >= 0.6 && < 0.7, + bytestring >= 0.10 && < 0.13, + random >= 1.0 && < 1.3, + mtl >= 2.2.1 && < 2.4, + ansi-terminal >= 0.5 + hs-source-dirs: src + ghc-options: -fno-warn-unused-do-bind + default-language: Haskell2010 + default-extensions: CPP, + ExistentialQuantification, + FlexibleInstances, + DeriveDataTypeable, + RankNTypes, + OverloadedStrings, + OverlappingInstances diff --git a/packages/network-transport-tests/src/Network/Transport/Tests.hs b/packages/network-transport-tests/src/Network/Transport/Tests.hs new file mode 100644 index 00000000..65c49946 --- /dev/null +++ b/packages/network-transport-tests/src/Network/Transport/Tests.hs @@ -0,0 +1,1090 @@ +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE CPP #-} +module Network.Transport.Tests where + +import Prelude hiding + ( (>>=) + , return + , fail + , (>>) + ) +import Control.Concurrent (forkIO, killThread, yield) +import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar, readMVar, tryTakeMVar, modifyMVar_, newMVar) +import Control.Exception + ( evaluate + , throw + , throwIO + , bracket + , catch + , ErrorCall(..) + ) +import Control.Monad (replicateM, replicateM_, when, guard, forM_, unless) +import Control.Monad.Except () +import Control.Applicative ((<$>)) +import Network.Transport +import Network.Transport.Internal (tlog, tryIO, timeoutMaybe) +import Network.Transport.Util (spawn) +import System.Random (randomIO) +import Data.ByteString (ByteString) +import Data.ByteString.Char8 (pack) +import Data.Map (Map) +import qualified Data.Map as Map (empty, insert, delete, findWithDefault, adjust, null, toList, map) +import Data.String (fromString) +import Data.List (permutations) +import Network.Transport.Tests.Auxiliary (forkTry, runTests, trySome, randomThreadDelay) +import Network.Transport.Tests.Traced + +-- | Server that echoes messages straight back to the origin endpoint. +echoServer :: EndPoint -> IO () +echoServer endpoint = do + go Map.empty + where + go :: Map ConnectionId Connection -> IO () + go cs = do + event <- receive endpoint + case event of + ConnectionOpened cid rel addr -> do + tlog $ "Opened new connection " ++ show cid + Right conn <- connect endpoint addr rel defaultConnectHints + go (Map.insert cid conn cs) + Received cid payload -> do + send (Map.findWithDefault (error $ "Received: Invalid cid " ++ show cid) cid cs) payload + go cs + ConnectionClosed cid -> do + tlog $ "Close connection " ++ show cid + close (Map.findWithDefault (error $ "ConnectionClosed: Invalid cid " ++ show cid) cid cs) + go (Map.delete cid cs) + ReceivedMulticast _ _ -> + -- Ignore + go cs + ErrorEvent _ -> + putStrLn $ "Echo server received error event: " ++ show event + EndPointClosed -> + return () + +-- | Ping client used in a few tests +ping :: EndPoint -> EndPointAddress -> Int -> ByteString -> IO () +ping endpoint server numPings msg = do + -- Open connection to the server + tlog "Connect to echo server" + Right conn <- connect endpoint server ReliableOrdered defaultConnectHints + + -- Wait for the server to open reply connection + tlog "Wait for ConnectionOpened message" + ConnectionOpened cid _ _ <- receive endpoint + + -- Send pings and wait for reply + tlog "Send ping and wait for reply" + replicateM_ numPings $ do + send conn [msg] + Received cid' [reply] <- receive endpoint ; True <- return $ cid == cid' && reply == msg + return () + + -- Close the connection + tlog "Close the connection" + close conn + + -- Wait for the server to close its connection to us + tlog "Wait for ConnectionClosed message" + ConnectionClosed cid' <- receive endpoint ; True <- return $ cid == cid' + + -- Done + tlog "Ping client done" + +-- | Basic ping test +testPingPong :: Transport -> Int -> IO () +testPingPong transport numPings = do + tlog "Starting ping pong test" + server <- spawn transport echoServer + result <- newEmptyMVar + + -- Client + forkTry $ do + tlog "Ping client" + Right endpoint <- newEndPoint transport + ping endpoint server numPings "ping" + putMVar result () + + takeMVar result + +-- | Test that endpoints don't get confused +testEndPoints :: Transport -> Int -> IO () +testEndPoints transport numPings = do + server <- spawn transport echoServer + dones <- replicateM 2 newEmptyMVar + + forM_ (zip dones ['A'..]) $ \(done, name) -> forkTry $ do + let name' :: ByteString + name' = pack [name] + Right endpoint <- newEndPoint transport + tlog $ "Ping client " ++ show name' ++ ": " ++ show (address endpoint) + ping endpoint server numPings name' + putMVar done () + + forM_ dones takeMVar + +-- Test that connections don't get confused +testConnections :: Transport -> Int -> IO () +testConnections transport numPings = do + server <- spawn transport echoServer + result <- newEmptyMVar + + -- Client + forkTry $ do + Right endpoint <- newEndPoint transport + + -- Open two connections to the server + Right conn1 <- connect endpoint server ReliableOrdered defaultConnectHints + ConnectionOpened serv1 _ _ <- receive endpoint + + Right conn2 <- connect endpoint server ReliableOrdered defaultConnectHints + ConnectionOpened serv2 _ _ <- receive endpoint + + -- One thread to send "pingA" on the first connection + forkTry $ replicateM_ numPings $ send conn1 ["pingA"] + + -- One thread to send "pingB" on the second connection + forkTry $ replicateM_ numPings $ send conn2 ["pingB"] + + -- Verify server responses + let verifyResponse 0 = putMVar result () + verifyResponse n = do + event <- receive endpoint + case event of + Received cid [payload] -> do + when (cid == serv1 && payload /= "pingA") $ error "Wrong message" + when (cid == serv2 && payload /= "pingB") $ error "Wrong message" + verifyResponse (n - 1) + _ -> + verifyResponse n + verifyResponse (2 * numPings) + + takeMVar result + +-- | Test that closing one connection does not close the other +testCloseOneConnection :: Transport -> Int -> IO () +testCloseOneConnection transport numPings = do + server <- spawn transport echoServer + result <- newEmptyMVar + + -- Client + forkTry $ do + Right endpoint <- newEndPoint transport + + -- Open two connections to the server + Right conn1 <- connect endpoint server ReliableOrdered defaultConnectHints + ConnectionOpened serv1 _ _ <- receive endpoint + + Right conn2 <- connect endpoint server ReliableOrdered defaultConnectHints + ConnectionOpened serv2 _ _ <- receive endpoint + + -- One thread to send "pingA" on the first connection + forkTry $ do + replicateM_ numPings $ send conn1 ["pingA"] + close conn1 + + -- One thread to send "pingB" on the second connection + forkTry $ replicateM_ (numPings * 2) $ send conn2 ["pingB"] + + -- Verify server responses + let verifyResponse 0 = putMVar result () + verifyResponse n = do + event <- receive endpoint + case event of + Received cid [payload] -> do + when (cid == serv1 && payload /= "pingA") $ error "Wrong message" + when (cid == serv2 && payload /= "pingB") $ error "Wrong message" + verifyResponse (n - 1) + _ -> + verifyResponse n + verifyResponse (3 * numPings) + + takeMVar result + +-- | Test that if A connects to B and B connects to A, B can still send to A after +-- A closes its connection to B (for instance, in the TCP transport, the socket pair +-- connecting A and B should not yet be closed). +testCloseOneDirection :: Transport -> Int -> IO () +testCloseOneDirection transport numPings = do + addrA <- newEmptyMVar + addrB <- newEmptyMVar + doneA <- newEmptyMVar + doneB <- newEmptyMVar + + -- A + forkTry $ do + tlog "A" + Right endpoint <- newEndPoint transport + tlog (show (address endpoint)) + putMVar addrA (address endpoint) + + -- Connect to B + tlog "Connect to B" + Right conn <- readMVar addrB >>= \addr -> connect endpoint addr ReliableOrdered defaultConnectHints + + -- Wait for B to connect to us + tlog "Wait for B" + ConnectionOpened cid _ _ <- receive endpoint + + -- Send pings to B + tlog "Send pings to B" + replicateM_ numPings $ send conn ["ping"] + + -- Close our connection to B + tlog "Close connection" + close conn + + -- Wait for B's pongs + tlog "Wait for pongs from B" + replicateM_ numPings $ do Received _ _ <- receive endpoint ; return () + + -- Wait for B to close it's connection to us + tlog "Wait for B to close connection" + ConnectionClosed cid' <- receive endpoint + guard (cid == cid') + + -- Done + tlog "Done" + putMVar doneA () + + -- B + forkTry $ do + tlog "B" + Right endpoint <- newEndPoint transport + tlog (show (address endpoint)) + putMVar addrB (address endpoint) + + -- Wait for A to connect + tlog "Wait for A to connect" + ConnectionOpened cid _ _ <- receive endpoint + + -- Connect to A + tlog "Connect to A" + Right conn <- readMVar addrA >>= \addr -> connect endpoint addr ReliableOrdered defaultConnectHints + + -- Wait for A's pings + tlog "Wait for pings from A" + replicateM_ numPings $ do Received _ _ <- receive endpoint ; return () + + -- Wait for A to close it's connection to us + tlog "Wait for A to close connection" + ConnectionClosed cid' <- receive endpoint + guard (cid == cid') + + -- Send pongs to A + tlog "Send pongs to A" + replicateM_ numPings $ send conn ["pong"] + + -- Close our connection to A + tlog "Close connection to A" + close conn + + -- Done + tlog "Done" + putMVar doneB () + + mapM_ takeMVar [doneA, doneB] + +-- | Collect events and order them by connection ID +collect :: EndPoint -> Maybe Int -> Maybe Int -> IO [(ConnectionId, [[ByteString]])] +collect endPoint maxEvents timeout = go maxEvents Map.empty Map.empty + where + -- TODO: for more serious use of this function we'd need to make these arguments strict + go (Just 0) open closed = finish open closed + go n open closed = do + mEvent <- tryIO . timeoutMaybe timeout (userError "timeout") $ receive endPoint + case mEvent of + Left _ -> finish open closed + Right event -> do + let n' = (\x -> x - 1) <$> n + case event of + ConnectionOpened cid _ _ -> + go n' (Map.insert cid [] open) closed + ConnectionClosed cid -> + let list = Map.findWithDefault (error "Invalid ConnectionClosed") cid open in + go n' (Map.delete cid open) (Map.insert cid list closed) + Received cid msg -> + go n' (Map.adjust (msg :) cid open) closed + ReceivedMulticast _ _ -> + fail "Unexpected multicast" + ErrorEvent _ -> + fail "Unexpected error" + EndPointClosed -> + fail "Unexpected endpoint closure" + + finish open closed = + if Map.null open + then return . Map.toList . Map.map reverse $ closed + else fail $ "Open connections: " ++ show (map fst . Map.toList $ open) + +-- | Open connection, close it, then reopen it +-- (In the TCP transport this means the socket will be closed, then reopened) +-- +-- Note that B cannot expect to receive all of A's messages on the first connection +-- before receiving the messages on the second connection. What might (and sometimes +-- does) happen is that finishes sending all of its messages on the first connection +-- (in the TCP transport, the first socket pair) while B is behind on reading _from_ +-- this connection (socket pair) -- the messages are "in transit" on the network +-- (these tests are done on localhost, so there are in some OS buffer). Then when +-- A opens the second connection (socket pair) B will spawn a new thread for this +-- connection, and hence might start interleaving messages from the first and second +-- connection. +-- +-- This is correct behaviour, however: the transport API guarantees reliability and +-- ordering _per connection_, but not _across_ connections. +testCloseReopen :: Transport -> Int -> IO () +testCloseReopen transport numPings = do + addrB <- newEmptyMVar + doneB <- newEmptyMVar + + let numRepeats = 2 :: Int + + -- A + forkTry $ do + Right endpoint <- newEndPoint transport + + forM_ [1 .. numRepeats] $ \i -> do + tlog "A connecting" + -- Connect to B + Right conn <- readMVar addrB >>= \addr -> connect endpoint addr ReliableOrdered defaultConnectHints + + tlog "A pinging" + -- Say hi + forM_ [1 .. numPings] $ \j -> send conn [pack $ "ping" ++ show i ++ "/" ++ show j] + + tlog "A closing" + -- Disconnect again + close conn + + tlog "A finishing" + + -- B + forkTry $ do + Right endpoint <- newEndPoint transport + putMVar addrB (address endpoint) + + eventss <- collect endpoint (Just (numRepeats * (numPings + 2))) Nothing + + forM_ (zip [1 .. numRepeats] eventss) $ \(i, (_, events)) -> do + forM_ (zip [1 .. numPings] events) $ \(j, event) -> do + guard (event == [pack $ "ping" ++ show i ++ "/" ++ show j]) + + putMVar doneB () + + takeMVar doneB + +-- | Test lots of parallel connection attempts +testParallelConnects :: Transport -> Int -> IO () +testParallelConnects transport numPings = do + server <- spawn transport echoServer + done <- newEmptyMVar + + Right endpoint <- newEndPoint transport + + -- Spawn lots of clients + forM_ [1 .. numPings] $ \i -> forkTry $ do + Right conn <- connect endpoint server ReliableOrdered defaultConnectHints + send conn [pack $ "ping" ++ show i] + send conn [pack $ "ping" ++ show i] + close conn + + forkTry $ do + eventss <- collect endpoint (Just (numPings * 4)) Nothing + -- Check that no pings got sent to the wrong connection + forM_ eventss $ \(_, [[ping1], [ping2]]) -> + guard (ping1 == ping2) + putMVar done () + + takeMVar done + +-- | Test that sending an error to self gives an error in the sender +testSelfSend :: Transport -> IO () +testSelfSend transport = do + Right endpoint <- newEndPoint transport + + Right conn <- connect endpoint (address endpoint) ReliableOrdered + defaultConnectHints + + -- Must clear the ConnectionOpened event or else sending may block + ConnectionOpened _ _ _ <- receive endpoint + + do send conn [ error "bang!" ] + error "testSelfSend: send didn't fail" + `catch` (\(ErrorCall "bang!") -> return ()) + + close conn + + -- Must clear this event or else closing the end point may block. + ConnectionClosed _ <- receive endpoint + + closeEndPoint endpoint + +-- | Test that sending on a closed connection gives an error +testSendAfterClose :: Transport -> Int -> IO () +testSendAfterClose transport numRepeats = do + server <- spawn transport echoServer + clientDone <- newEmptyMVar + + forkTry $ do + Right endpoint <- newEndPoint transport + + -- We request two lightweight connections + replicateM numRepeats $ do + Right conn1 <- connect endpoint server ReliableOrdered defaultConnectHints + Right conn2 <- connect endpoint server ReliableOrdered defaultConnectHints + + -- Close the second, but leave the first open; then output on the second + -- connection (i.e., on a closed connection while there is still another + -- connection open) + close conn2 + Left (TransportError SendClosed _) <- send conn2 ["ping2"] + + -- Now close the first connection, and output on it (i.e., output while + -- there are no lightweight connection at all anymore) + close conn1 + Left (TransportError SendClosed _) <- send conn2 ["ping2"] + + return () + + putMVar clientDone () + + takeMVar clientDone + +-- | Test that closing the same connection twice has no effect +testCloseTwice :: Transport -> Int -> IO () +testCloseTwice transport numRepeats = do + server <- spawn transport echoServer + clientDone <- newEmptyMVar + + forkTry $ do + Right endpoint <- newEndPoint transport + + replicateM numRepeats $ do + -- We request two lightweight connections + Right conn1 <- connect endpoint server ReliableOrdered defaultConnectHints + Right conn2 <- connect endpoint server ReliableOrdered defaultConnectHints + + -- Close the second one twice + close conn2 + close conn2 + + -- Then send a message on the first and close that twice too + send conn1 ["ping"] + close conn1 + + -- Verify expected response from the echo server + ConnectionOpened cid1 _ _ <- receive endpoint + ConnectionOpened cid2 _ _ <- receive endpoint + -- ordering of the following messages may differ depending of + -- implementation + ms <- replicateM 3 $ receive endpoint + True <- return $ testStreams ms [ [ ConnectionClosed cid2 ] + , [ Received cid1 ["ping"] + , ConnectionClosed cid1 ] + ] + return () + + putMVar clientDone () + + takeMVar clientDone + +-- | Test that we can connect an endpoint to itself +testConnectToSelf :: Transport -> Int -> IO () +testConnectToSelf transport numPings = do + done <- newEmptyMVar + reconnect <- newEmptyMVar + Right endpoint <- newEndPoint transport + + tlog "Creating self-connection" + Right conn <- connect endpoint (address endpoint) ReliableOrdered defaultConnectHints + + tlog "Talk to myself" + + -- One thread to write to the endpoint + forkTry $ do + tlog $ "writing" + + tlog $ "Sending ping" + replicateM_ numPings $ send conn ["ping"] + + tlog $ "Closing connection" + close conn + readMVar reconnect + ConnectionOpened cid' _ _ <- receive endpoint + ConnectionClosed cid'' <- receive endpoint ; True <- return $ cid' == cid'' + return () + + -- And one thread to read + forkTry $ do + tlog $ "reading" + + tlog "Waiting for ConnectionOpened" + ConnectionOpened cid _ addr <- receive endpoint + + tlog "Waiting for Received" + replicateM_ numPings $ do + Received cid' ["ping"] <- receive endpoint ; True <- return $ cid == cid' + return () + + tlog "Waiting for ConnectionClosed" + ConnectionClosed cid' <- receive endpoint ; True <- return $ cid == cid' + + putMVar reconnect () + + -- Check that the addr supplied also connects to self. + -- The other thread verifies this. + Right conn <- connect endpoint addr ReliableOrdered defaultConnectHints + close conn + + tlog "Done" + putMVar done () + + takeMVar done + +-- | Test that we can connect an endpoint to itself multiple times +testConnectToSelfTwice :: Transport -> Int -> IO () +testConnectToSelfTwice transport numPings = do + done <- newEmptyMVar + Right endpoint <- newEndPoint transport + + tlog "Talk to myself" + + -- An MVar to ensure that the node which sends pingA will connect first, as + -- this determines the order of the events given out by 'collect' and is + -- essential for the equality test there. + firstConnectionMade <- newEmptyMVar + + -- One thread to write to the endpoint using the first connection + forkTry $ do + tlog "Creating self-connection" + Right conn1 <- connect endpoint (address endpoint) ReliableOrdered defaultConnectHints + putMVar firstConnectionMade () + + tlog $ "writing" + + tlog $ "Sending ping" + replicateM_ numPings $ send conn1 ["pingA"] + + tlog $ "Closing connection" + close conn1 + + -- One thread to write to the endpoint using the second connection + forkTry $ do + takeMVar firstConnectionMade + tlog "Creating self-connection" + Right conn2 <- connect endpoint (address endpoint) ReliableOrdered defaultConnectHints + tlog $ "writing" + + tlog $ "Sending ping" + replicateM_ numPings $ send conn2 ["pingB"] + + tlog $ "Closing connection" + close conn2 + + -- And one thread to read + forkTry $ do + tlog $ "reading" + + [(_, events1), (_, events2)] <- collect endpoint (Just (2 * (numPings + 2))) Nothing + True <- return $ events1 == replicate numPings ["pingA"] + True <- return $ events2 == replicate numPings ["pingB"] + + tlog "Done" + putMVar done () + + takeMVar done + +-- | Test that we self-connections no longer work once we close our endpoint +-- or our transport +testCloseSelf :: IO (Either String Transport) -> IO () +testCloseSelf newTransport = do + Right transport <- newTransport + Right endpoint1 <- newEndPoint transport + Right endpoint2 <- newEndPoint transport + Right conn1 <- connect endpoint1 (address endpoint1) ReliableOrdered defaultConnectHints + ConnectionOpened _ _ _ <- receive endpoint1 + Right conn2 <- connect endpoint1 (address endpoint1) ReliableOrdered defaultConnectHints + ConnectionOpened _ _ _ <- receive endpoint1 + Right conn3 <- connect endpoint2 (address endpoint2) ReliableOrdered defaultConnectHints + ConnectionOpened _ _ _ <- receive endpoint2 + + -- Close the conneciton and try to send + close conn1 + ConnectionClosed _ <- receive endpoint1 + Left (TransportError SendClosed _) <- send conn1 ["ping"] + + -- Close the first endpoint. We should not be able to use the first + -- connection anymore, or open more self connections, but the self connection + -- to the second endpoint should still be fine + closeEndPoint endpoint1 + EndPointClosed <- receive endpoint1 + Left (TransportError SendFailed _) <- send conn2 ["ping"] + Left (TransportError ConnectFailed _) <- connect endpoint1 (address endpoint1) ReliableOrdered defaultConnectHints + Right () <- send conn3 ["ping"] + Received _ _ <- receive endpoint2 + + -- Close the transport; now the second should no longer work + closeTransport transport + Left (TransportError SendFailed _) <- send conn3 ["ping"] + Left r <- connect endpoint2 (address endpoint2) ReliableOrdered defaultConnectHints + case r of + TransportError ConnectFailed _ -> return () + _ -> do putStrLn $ "Actual: " ++ show r + TransportError ConnectFailed _ <- return r + return () + + return () + +-- | Test various aspects of 'closeEndPoint' +testCloseEndPoint :: Transport -> Int -> IO () +testCloseEndPoint transport _ = do + serverFirstTestDone <- newEmptyMVar + serverDone <- newEmptyMVar + clientDone <- newEmptyMVar + clientAddr1 <- newEmptyMVar + clientAddr2 <- newEmptyMVar + serverAddr <- newEmptyMVar + + -- Server + forkTry $ do + Right endpoint <- newEndPoint transport + putMVar serverAddr (address endpoint) + + -- First test (see client) + do + theirAddr <- readMVar clientAddr1 + ConnectionOpened cid ReliableOrdered addr <- receive endpoint + -- Ensure that connecting to the supplied address reaches the peer. + Right conn <- connect endpoint addr ReliableOrdered defaultConnectHints + close conn + putMVar serverFirstTestDone () + ConnectionClosed cid' <- receive endpoint ; True <- return $ cid == cid' + putMVar serverAddr (address endpoint) + return () + + -- Second test + do + theirAddr <- readMVar clientAddr2 + + ConnectionOpened cid ReliableOrdered addr <- receive endpoint + -- Ensure that connecting to the supplied address reaches the peer. + Right conn <- connect endpoint addr ReliableOrdered defaultConnectHints + close conn + Received cid' ["ping"] <- receive endpoint ; True <- return $ cid == cid' + + Right conn <- connect endpoint theirAddr ReliableOrdered defaultConnectHints + send conn ["pong"] + + ConnectionClosed cid'' <- receive endpoint ; True <- return $ cid == cid'' + ErrorEvent (TransportError (EventConnectionLost addr') _) <- receive endpoint ; True <- return $ addr' == theirAddr + + Left (TransportError SendFailed _) <- send conn ["pong2"] + + return () + + putMVar serverDone () + + -- Client + forkTry $ do + + -- First test: close endpoint with one outgoing but no incoming connections + do + theirAddr <- takeMVar serverAddr + Right endpoint <- newEndPoint transport + putMVar clientAddr1 (address endpoint) + + -- Connect to the server, then close the endpoint without disconnecting explicitly + Right _ <- connect endpoint theirAddr ReliableOrdered defaultConnectHints + ConnectionOpened cid _ _ <- receive endpoint + ConnectionClosed cid' <- receive endpoint ; True <- return $ cid == cid' + -- Don't close before the remote server had a chance to digest the + -- connection. + readMVar serverFirstTestDone + closeEndPoint endpoint + EndPointClosed <- receive endpoint + return () + + -- Second test: close endpoint with one outgoing and one incoming connection + do + theirAddr <- takeMVar serverAddr + Right endpoint <- newEndPoint transport + putMVar clientAddr2 (address endpoint) + + Right conn <- connect endpoint theirAddr ReliableOrdered defaultConnectHints + ConnectionOpened cid _ _ <- receive endpoint + ConnectionClosed cid' <- receive endpoint ; True <- return $ cid == cid' + send conn ["ping"] + + -- Reply from the server + ConnectionOpened cid ReliableOrdered addr <- receive endpoint + Received cid' ["pong"] <- receive endpoint ; True <- return $ cid == cid' + + -- Close the endpoint + closeEndPoint endpoint + EndPointClosed <- receive endpoint + + -- Attempt to send should fail with connection closed + Left (TransportError SendFailed _) <- send conn ["ping2"] + + -- An attempt to close the already closed connection should just return + () <- close conn + + -- And so should an attempt to connect + Left (TransportError ConnectFailed _) <- connect endpoint theirAddr ReliableOrdered defaultConnectHints + + return () + + putMVar clientDone () + + mapM_ takeMVar [serverDone, clientDone] + +-- Test closeTransport +-- +-- This tests many of the same things that testEndPoint does, and some more +testCloseTransport :: IO (Either String Transport) -> IO () +testCloseTransport newTransport = do + serverDone <- newEmptyMVar + clientDone <- newEmptyMVar + clientAddr1 <- newEmptyMVar + clientAddr2 <- newEmptyMVar + serverAddr <- newEmptyMVar + + -- Server + forkTry $ do + Right transport <- newTransport + Right endpoint <- newEndPoint transport + putMVar serverAddr (address endpoint) + + -- Client sets up first endpoint + theirAddr1 <- readMVar clientAddr1 + ConnectionOpened cid1 ReliableOrdered addr <- receive endpoint + -- Test that the address given does indeed point back to the client + Right conn <- connect endpoint theirAddr1 ReliableOrdered defaultConnectHints + close conn + Right conn <- connect endpoint addr ReliableOrdered defaultConnectHints + close conn + + -- Client sets up second endpoint + theirAddr2 <- readMVar clientAddr2 + + ConnectionOpened cid2 ReliableOrdered addr' <- receive endpoint + -- We're going to use addr' to connect back to the server, which tests + -- that it's a valid address (but not *necessarily* == to theirAddr2 + + Received cid2' ["ping"] <- receive endpoint ; True <- return $ cid2' == cid2 + + Right conn <- connect endpoint theirAddr2 ReliableOrdered defaultConnectHints + send conn ["pong"] + close conn + Right conn <- connect endpoint addr' ReliableOrdered defaultConnectHints + send conn ["pong"] + + -- Client now closes down its transport. We should receive connection closed messages (we don't know the precise order, however) + -- TODO: should we get an EventConnectionLost for theirAddr1? We have no outgoing connections + evs <- replicateM 3 $ receive endpoint + let expected = [ ConnectionClosed cid1 + , ConnectionClosed cid2 + -- , ErrorEvent (TransportError (EventConnectionLost theirAddr1) "") + , ErrorEvent (TransportError (EventConnectionLost addr') "") + ] + True <- return $ expected `elem` permutations evs + + -- An attempt to send to the endpoint should now fail + Left (TransportError SendFailed _) <- send conn ["pong2"] + + putMVar serverDone () + + -- Client + forkTry $ do + Right transport <- newTransport + theirAddr <- readMVar serverAddr + + -- Set up endpoint with one outgoing but no incoming connections + Right endpoint1 <- newEndPoint transport + putMVar clientAddr1 (address endpoint1) + + -- Connect to the server, then close the endpoint without disconnecting explicitly + Right _ <- connect endpoint1 theirAddr ReliableOrdered defaultConnectHints + -- Server connects back to verify that both addresses they have for us + -- are suitable to reach us. + ConnectionOpened cid ReliableOrdered _ <- receive endpoint1 + ConnectionClosed cid' <- receive endpoint1 ; True <- return $ cid == cid' + ConnectionOpened cid ReliableOrdered _ <- receive endpoint1 + ConnectionClosed cid' <- receive endpoint1 ; True <- return $ cid == cid' + + -- Set up an endpoint with one outgoing and one incoming connection + Right endpoint2 <- newEndPoint transport + putMVar clientAddr2 (address endpoint2) + + -- The outgoing connection. + Right conn <- connect endpoint2 theirAddr ReliableOrdered defaultConnectHints + send conn ["ping"] + + -- Reply from the server. It will connect twice, using both addresses + -- (the one that the client sees, and the one that the server sees). + ConnectionOpened cid ReliableOrdered _ <- receive endpoint2 + Received cid' ["pong"] <- receive endpoint2 ; True <- return $ cid == cid' + ConnectionClosed cid'' <- receive endpoint2 ; True <- return $ cid == cid'' + ConnectionOpened cid ReliableOrdered _ <- receive endpoint2 + Received cid' ["pong"] <- receive endpoint2 ; True <- return $ cid == cid' + + -- Now shut down the entire transport + closeTransport transport + + -- Both endpoints should report that they have been closed + EndPointClosed <- receive endpoint1 + EndPointClosed <- receive endpoint2 + + -- Attempt to send should fail with connection closed + Left (TransportError SendFailed _) <- send conn ["ping2"] + + -- An attempt to close the already closed connection should just return + () <- close conn + + -- And so should an attempt to connect on either endpoint + Left (TransportError ConnectFailed _) <- connect endpoint1 theirAddr ReliableOrdered defaultConnectHints + Left (TransportError ConnectFailed _) <- connect endpoint2 theirAddr ReliableOrdered defaultConnectHints + + -- And finally, so should an attempt to create a new endpoint + Left (TransportError NewEndPointFailed _) <- newEndPoint transport + + putMVar clientDone () + + mapM_ takeMVar [serverDone, clientDone] + +-- | Remote node attempts to connect to a closed local endpoint +testConnectClosedEndPoint :: Transport -> IO () +testConnectClosedEndPoint transport = do + serverAddr <- newEmptyMVar + serverClosed <- newEmptyMVar + clientDone <- newEmptyMVar + + -- Server + forkTry $ do + Right endpoint <- newEndPoint transport + putMVar serverAddr (address endpoint) + + closeEndPoint endpoint + putMVar serverClosed () + + -- Client + forkTry $ do + Right endpoint <- newEndPoint transport + readMVar serverClosed + + Left (TransportError ConnectNotFound _) <- readMVar serverAddr >>= \addr -> connect endpoint addr ReliableOrdered defaultConnectHints + + putMVar clientDone () + + takeMVar clientDone + +-- | We should receive an exception when doing a 'receive' after we have been +-- notified that an endpoint has been closed +testExceptionOnReceive :: IO (Either String Transport) -> IO () +testExceptionOnReceive newTransport = do + Right transport <- newTransport + + -- Test one: when we close an endpoint specifically + Right endpoint1 <- newEndPoint transport + closeEndPoint endpoint1 + EndPointClosed <- receive endpoint1 + Left _ <- trySome (receive endpoint1 >>= evaluate) + + -- Test two: when we close the entire transport + Right endpoint2 <- newEndPoint transport + closeTransport transport + EndPointClosed <- receive endpoint2 + Left _ <- trySome (receive endpoint2 >>= evaluate) + + return () + +-- | Test what happens when the argument to 'send' is an exceptional value +testSendException :: IO (Either String Transport) -> IO () +testSendException newTransport = do + Right transport <- newTransport + Right endpoint1 <- newEndPoint transport + Right endpoint2 <- newEndPoint transport + + -- Connect endpoint1 to endpoint2 + Right conn <- connect endpoint1 (address endpoint2) ReliableOrdered defaultConnectHints + ConnectionOpened _ _ _ <- receive endpoint2 + + -- Send an exceptional value + Left (TransportError SendFailed _) <- send conn (throw $ userError "uhoh") + + -- This will have been as a failure to send by endpoint1, which will + -- therefore have closed the socket. In turn this will have caused endpoint2 + -- to report that the connection was lost + ErrorEvent (TransportError (EventConnectionLost _) _) <- receive endpoint1 + ErrorEvent (TransportError (EventConnectionLost _) _) <- receive endpoint2 + + -- A new connection will re-establish the connection + Right conn2 <- connect endpoint1 (address endpoint2) ReliableOrdered defaultConnectHints + send conn2 ["ping"] + close conn2 + + ConnectionOpened _ _ _ <- receive endpoint2 + Received _ ["ping"] <- receive endpoint2 + ConnectionClosed _ <- receive endpoint2 + + return () + +-- | If threads get killed while executing a 'connect', 'send', or 'close', this +-- should not affect other threads. +-- +-- The intention of this test is to see what happens when a asynchronous +-- exception happes _while executing a send_. This is exceedingly difficult to +-- guarantee, however. Hence we run a large number of tests and insert random +-- thread delays -- and even then it might not happen. Moreover, it will only +-- happen when we run on multiple cores. +testKill :: IO (Either String Transport) -> Int -> IO () +testKill newTransport numThreads = do + Right transport1 <- newTransport + Right transport2 <- newTransport + Right endpoint1 <- newEndPoint transport1 + Right endpoint2 <- newEndPoint transport2 + + threads <- replicateM numThreads . forkIO $ do + randomThreadDelay 100 + bracket (connect endpoint1 (address endpoint2) ReliableOrdered defaultConnectHints) + -- Note that we should not insert a randomThreadDelay into the + -- exception handler itself as this means that the exception handler + -- could be interrupted and we might not close + (\(Right conn) -> close conn) + (\(Right conn) -> do randomThreadDelay 100 + Right () <- send conn ["ping"] + randomThreadDelay 100) + + numAlive <- newMVar (0 :: Int) + + -- Kill half of those threads + forkIO . forM_ threads $ \tid -> do + shouldKill <- randomIO + if shouldKill + then randomThreadDelay 600 >> killThread tid + else modifyMVar_ numAlive (return . (+ 1)) + + -- Since it is impossible to predict when the kill exactly happens, we don't + -- know how many connects were opened and how many pings were sent. But we + -- should not have any open connections (if we do, collect will throw an + -- error) and we should have at least the number of pings equal to the number + -- of threads we did *not* kill + eventss <- collect endpoint2 Nothing (Just 1000000) + let actualPings = sum . map (length . snd) $ eventss + expectedPings <- takeMVar numAlive + unless (actualPings >= expectedPings) $ + throwIO (userError "Missing pings") + +-- print (actualPings, expectedPings) + + +-- | Set up conditions with a high likelyhood of "crossing" (for transports +-- that multiplex lightweight connections across heavyweight connections) +testCrossing :: Transport -> Int -> IO () +testCrossing transport numRepeats = do + [aAddr, bAddr] <- replicateM 2 newEmptyMVar + [aDone, bDone] <- replicateM 2 newEmptyMVar + [aGo, bGo] <- replicateM 2 newEmptyMVar + [aTimeout, bTimeout] <- replicateM 2 newEmptyMVar + + let hints = defaultConnectHints { + connectTimeout = Just 5000000 + } + + -- A + forkTry $ do + Right endpoint <- newEndPoint transport + putMVar aAddr (address endpoint) + theirAddress <- readMVar bAddr + + replicateM_ numRepeats $ do + takeMVar aGo >> yield + -- Because we are creating lots of connections, it's possible that + -- connect times out (for instance, in the TCP transport, + -- Network.Socket.connect may time out). We shouldn't regard this as an + -- error in the Transport, though. + connectResult <- connect endpoint theirAddress ReliableOrdered hints + case connectResult of + Right conn -> close conn + Left (TransportError ConnectTimeout _) -> putMVar aTimeout () + Left (TransportError ConnectFailed _) -> readMVar bTimeout + Left err -> throwIO . userError $ "testCrossed: " ++ show err + putMVar aDone () + + -- B + forkTry $ do + Right endpoint <- newEndPoint transport + putMVar bAddr (address endpoint) + theirAddress <- readMVar aAddr + + replicateM_ numRepeats $ do + takeMVar bGo >> yield + connectResult <- connect endpoint theirAddress ReliableOrdered hints + case connectResult of + Right conn -> close conn + Left (TransportError ConnectTimeout _) -> putMVar bTimeout () + Left (TransportError ConnectFailed _) -> readMVar aTimeout + Left err -> throwIO . userError $ "testCrossed: " ++ show err + putMVar bDone () + + -- Driver + forM_ [1 .. numRepeats] $ \_i -> do + -- putStrLn $ "Round " ++ show _i + tryTakeMVar aTimeout + tryTakeMVar bTimeout + b <- randomIO + if b then do putMVar aGo () ; putMVar bGo () + else do putMVar bGo () ; putMVar aGo () + yield + takeMVar aDone + takeMVar bDone + +-- Transport tests +testTransport :: IO (Either String Transport) -> IO () +testTransport = testTransportWithFilter (const True) + +testTransportWithFilter :: (String -> Bool) -> IO (Either String Transport) -> IO () +testTransportWithFilter p newTransport = do + Right transport <- newTransport + runTests $ filter (p . fst) + [ ("PingPong", testPingPong transport numPings) + , ("EndPoints", testEndPoints transport numPings) + , ("Connections", testConnections transport numPings) + , ("CloseOneConnection", testCloseOneConnection transport numPings) + , ("CloseOneDirection", testCloseOneDirection transport numPings) + , ("CloseReopen", testCloseReopen transport numPings) + , ("ParallelConnects", testParallelConnects transport numPings) + , ("SelfSend", testSelfSend transport) + , ("SendAfterClose", testSendAfterClose transport 100) + , ("Crossing", testCrossing transport 10) + , ("CloseTwice", testCloseTwice transport 100) + , ("ConnectToSelf", testConnectToSelf transport numPings) + , ("ConnectToSelfTwice", testConnectToSelfTwice transport numPings) + , ("CloseSelf", testCloseSelf newTransport) + , ("CloseEndPoint", testCloseEndPoint transport numPings) + , ("CloseTransport", testCloseTransport newTransport) + , ("ConnectClosedEndPoint", testConnectClosedEndPoint transport) + , ("ExceptionOnReceive", testExceptionOnReceive newTransport) + , ("SendException", testSendException newTransport) + , ("Kill", testKill newTransport 1000) + ] + where + numPings = 10000 :: Int + + +-- Test that list is a union of stream message, with preserved ordering +-- within each stream. +-- Note: this function may not work if different streams contains equal +-- messages. +testStreams :: Eq a => [a] -> [[a]] -> Bool +testStreams [] ys = all null ys +testStreams (x:xs) ys = + case go [] ys of + [] -> False + ys' -> testStreams xs ys' + where + go _ [] = [] + go c ([]:zss) = go c zss + go c (z'@(z:zs):zss) + | x == z = (zs:c)++zss + | otherwise = go (z':c) zss diff --git a/packages/network-transport-tests/src/Network/Transport/Tests/Auxiliary.hs b/packages/network-transport-tests/src/Network/Transport/Tests/Auxiliary.hs new file mode 100644 index 00000000..9a3124c2 --- /dev/null +++ b/packages/network-transport-tests/src/Network/Transport/Tests/Auxiliary.hs @@ -0,0 +1,109 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE CPP #-} +module Network.Transport.Tests.Auxiliary + ( -- Running tests + runTest + , runTests + -- Writing tests + , forkTry + , trySome + , randomThreadDelay + ) where + +import Control.Concurrent (myThreadId, forkIO, ThreadId, throwTo, threadDelay) +import Control.Concurrent.Chan (Chan) +import Control.Monad (liftM2, unless) +import Control.Exception (SomeException, try, catch) +import System.Timeout (timeout) +import System.IO (stdout, hFlush) +import System.Console.ANSI ( SGR(SetColor, Reset) + , Color(Red, Green) + , ConsoleLayer(Foreground) + , ColorIntensity(Vivid) + , setSGR + ) +import System.Random (randomIO) +import Network.Transport +import Network.Transport.Tests.Traced (Traceable(..), traceShow) + +-- | Like fork, but throw exceptions in the child thread to the parent +forkTry :: IO () -> IO ThreadId +forkTry p = do + tid <- myThreadId + forkIO $ catch p (\e -> throwTo tid (e :: SomeException)) + +-- | Like try, but specialized to SomeException +trySome :: IO a -> IO (Either SomeException a) +trySome = try + +-- | Run the given test, catching timeouts and exceptions +runTest :: String -> IO () -> IO Bool +runTest description test = do + putStr $ "Running " ++ show description ++ ": " + hFlush stdout + done <- try . timeout 60000000 $ test -- 60 seconds + case done of + Left err -> failed $ "(exception: " ++ show (err :: SomeException) ++ ")" + Right Nothing -> failed $ "(timeout)" + Right (Just ()) -> ok + where + failed :: String -> IO Bool + failed err = do + setSGR [SetColor Foreground Vivid Red] + putStr "failed " + setSGR [Reset] + putStrLn err + return False + + ok :: IO Bool + ok = do + setSGR [SetColor Foreground Vivid Green] + putStrLn "ok" + setSGR [Reset] + return True + +-- | Run a bunch of tests and throw an exception if any fails +runTests :: [(String, IO ())] -> IO () +runTests tests = do + success <- foldr (liftM2 (&&) . uncurry runTest) (return True) $ tests + unless success $ fail "Some tests failed" + +-- | Random thread delay between 0 and the specified max +randomThreadDelay :: Int -> IO () +randomThreadDelay maxDelay = do + delay <- randomIO :: IO Int + threadDelay (delay `mod` maxDelay) + +-------------------------------------------------------------------------------- +-- traceShow instances -- +-------------------------------------------------------------------------------- + +instance Traceable EndPoint where + trace = const Nothing + +instance Traceable Transport where + trace = const Nothing + +instance Traceable Connection where + trace = const Nothing + +instance Traceable Event where + trace = traceShow + +instance Show err => Traceable (TransportError err) where + trace = traceShow + +instance Traceable EndPointAddress where + trace = traceShow . endPointAddressToByteString + +instance Traceable SomeException where + trace = traceShow + +instance Traceable ThreadId where + trace = const Nothing + +instance Traceable (Chan a) where + trace = const Nothing + +instance Traceable Float where + trace = traceShow diff --git a/packages/network-transport-tests/src/Network/Transport/Tests/Multicast.hs b/packages/network-transport-tests/src/Network/Transport/Tests/Multicast.hs new file mode 100644 index 00000000..cec26342 --- /dev/null +++ b/packages/network-transport-tests/src/Network/Transport/Tests/Multicast.hs @@ -0,0 +1,72 @@ +module Network.Transport.Tests.Multicast where + +import Network.Transport +import Control.Monad (replicateM, replicateM_, forM_, when) +import Control.Concurrent (forkIO) +import Control.Concurrent.MVar (MVar, newEmptyMVar, takeMVar, putMVar, readMVar) +import Data.ByteString (ByteString) +import Data.List (elemIndex) +import Network.Transport.Tests.Auxiliary (runTests) + +-- | Node for the "No confusion" test +noConfusionNode :: Transport -- ^ Transport + -> [MVar MulticastAddress] -- ^ my group : groups to subscribe to + -> [MVar ()] -- ^ I'm ready : others ready + -> Int -- ^ number of pings + -> [ByteString] -- ^ my message : messages from subscribed groups (same order as 'groups to subscribe to') + -> MVar () -- ^ I'm done + -> IO () +noConfusionNode transport groups ready numPings msgs done = do + -- Create a new endpoint + Right endpoint <- newEndPoint transport + + -- Create a new multicast group and broadcast its address + Right myGroup <- newMulticastGroup endpoint + putMVar (head groups) (multicastAddress myGroup) + + -- Subscribe to the given multicast groups + addrs <- mapM readMVar (tail groups) + forM_ addrs $ \addr -> do Right group <- resolveMulticastGroup endpoint addr + multicastSubscribe group + + -- Indicate that we're ready and wait for everybody else to be ready + putMVar (head ready) () + mapM_ readMVar (tail ready) + + -- Send messages.. + forkIO . replicateM_ numPings $ multicastSend myGroup [head msgs] + + -- ..while checking that the messages we receive are the right ones + replicateM_ (2 * numPings) $ do + event <- receive endpoint + case event of + ReceivedMulticast addr [msg] -> + let mix = addr `elemIndex` addrs in + case mix of + Nothing -> error "Message from unexpected source" + Just ix -> when (msgs !! (ix + 1) /= msg) $ error "Unexpected message" + _ -> + error "Unexpected event" + + -- Success + putMVar done () + +-- | Test that distinct multicast groups are not confused +testNoConfusion :: Transport -> Int -> IO () +testNoConfusion transport numPings = do + [group1, group2, group3] <- replicateM 3 newEmptyMVar + [readyA, readyB, readyC] <- replicateM 3 newEmptyMVar + [doneA, doneB, doneC] <- replicateM 3 newEmptyMVar + let [msgA, msgB, msgC] = ["A says hi", "B says hi", "C says hi"] + + forkIO $ noConfusionNode transport [group1, group1, group2] [readyA, readyB, readyC] numPings [msgA, msgA, msgB] doneA + forkIO $ noConfusionNode transport [group2, group1, group3] [readyB, readyC, readyA] numPings [msgB, msgA, msgC] doneB + forkIO $ noConfusionNode transport [group3, group2, group3] [readyC, readyA, readyB] numPings [msgC, msgB, msgC] doneC + + mapM_ takeMVar [doneA, doneB, doneC] + +-- | Test multicast +testMulticast :: Transport -> IO () +testMulticast transport = + runTests + [ ("NoConfusion", testNoConfusion transport 10000) ] diff --git a/packages/network-transport-tests/src/Network/Transport/Tests/Traced.hs b/packages/network-transport-tests/src/Network/Transport/Tests/Traced.hs new file mode 100644 index 00000000..8037d938 --- /dev/null +++ b/packages/network-transport-tests/src/Network/Transport/Tests/Traced.hs @@ -0,0 +1,208 @@ +{-# LANGUAGE CPP #-} +-- | Add tracing to the IO monad (see examples). +-- +-- [Usage] +-- +-- > {-# LANGUAGE RebindableSyntax #-} +-- > import Prelude hiding (catch, (>>=), (>>), return, fail) +-- > import Traced +-- +-- [Example] +-- +-- > test1 :: IO Int +-- > test1 = do +-- > Left x <- return (Left 1 :: Either Int Int) +-- > putStrLn "Hello world" +-- > Right y <- return (Left 2 :: Either Int Int) +-- > return (x + y) +-- +-- outputs +-- +-- > Hello world +-- > *** Exception: user error (Pattern match failure in do expression at Traced.hs:187:3-9) +-- > Trace: +-- > 0 Left 2 +-- > 1 Left 1 +-- +-- [Guards] +-- +-- Use the following idiom instead of using 'Control.Monad.guard': +-- +-- > test2 :: IO Int +-- > test2 = do +-- > Left x <- return (Left 1 :: Either Int Int) +-- > True <- return (x == 3) +-- > return x +-- +-- The advantage of this idiom is that it gives you line number information when the guard fails: +-- +-- > *Traced> test2 +-- > *** Exception: user error (Pattern match failure in do expression at Traced.hs:193:3-6) +-- > Trace: +-- > 0 Left 1 +module Network.Transport.Tests.Traced + ( MonadS(..) + , return + , (>>=) + , (>>) + , fail + , ifThenElse + , Showable(..) + , Traceable(..) + , traceShow + ) where + +import Prelude hiding + ( (>>=) + , return + , fail + , (>>) + ) +import qualified Prelude +import Control.Exception (catches, Handler(..), SomeException, throwIO, Exception(..), IOException) +import Control.Applicative ((<$>)) +import Data.Typeable (Typeable) +import Data.Maybe (catMaybes) +import Data.ByteString (ByteString) +import Data.Int (Int32, Int64) +import Data.Word (Word32, Word64) +import Control.Concurrent.MVar (MVar) + +-------------------------------------------------------------------------------- +-- MonadS class -- +-------------------------------------------------------------------------------- + +-- | Like 'Monad' but bind is only defined for 'Trace'able instances +class MonadS m where + returnS :: a -> m a + bindS :: Traceable a => m a -> (a -> m b) -> m b + failS :: String -> m a + seqS :: m a -> m b -> m b + +-- | Redefinition of 'Prelude.>>=' +(>>=) :: (MonadS m, Traceable a) => m a -> (a -> m b) -> m b +(>>=) = bindS + +-- | Redefinition of 'Prelude.>>' +(>>) :: MonadS m => m a -> m b -> m b +(>>) = seqS + +-- | Redefinition of 'Prelude.return' +return :: MonadS m => a -> m a +return = returnS + +-- | Redefinition of 'Prelude.fail' +fail :: MonadS m => String -> m a +fail = failS + +-------------------------------------------------------------------------------- +-- Trace typeclass (for adding elements to a trace -- +-------------------------------------------------------------------------------- + +data Showable = forall a. Show a => Showable a + +instance Show Showable where + show (Showable x) = show x + +mapShowable :: (forall a. Show a => a -> Showable) -> Showable -> Showable +mapShowable f (Showable x) = f x + +traceShow :: Show a => a -> Maybe Showable +traceShow = Just . Showable + +class Traceable a where + trace :: a -> Maybe Showable + +instance (Traceable a, Traceable b) => Traceable (Either a b) where + trace (Left x) = (mapShowable $ Showable . (Left :: forall c. c -> Either c ())) <$> trace x + trace (Right y) = (mapShowable $ Showable . (Right :: forall c. c -> Either () c)) <$> trace y + +instance (Traceable a, Traceable b) => Traceable (a, b) where + trace (x, y) = case (trace x, trace y) of + (Nothing, Nothing) -> Nothing + (Just t1, Nothing) -> traceShow t1 + (Nothing, Just t2) -> traceShow t2 + (Just t1, Just t2) -> traceShow (t1, t2) + +instance (Traceable a, Traceable b, Traceable c) => Traceable (a, b, c) where + trace (x, y, z) = case (trace x, trace y, trace z) of + (Nothing, Nothing, Nothing) -> Nothing + (Just t1, Nothing, Nothing) -> traceShow t1 + (Nothing, Just t2, Nothing) -> traceShow t2 + (Just t1, Just t2, Nothing) -> traceShow (t1, t2) + (Nothing, Nothing, Just t3) -> traceShow t3 + (Just t1, Nothing, Just t3) -> traceShow (t1, t3) + (Nothing, Just t2, Just t3) -> traceShow (t2, t3) + (Just t1, Just t2, Just t3) -> traceShow (t1, t2, t3) + +instance Traceable a => Traceable (Maybe a) where + trace Nothing = traceShow (Nothing :: Maybe ()) + trace (Just x) = mapShowable (Showable . Just) <$> trace x + +instance Traceable a => Traceable [a] where + trace = traceShow . catMaybes . map trace + +instance Traceable () where + trace = const Nothing + +instance Traceable Int where + trace = traceShow + +instance Traceable Int32 where + trace = traceShow + +instance Traceable Int64 where + trace = traceShow + +instance Traceable Word32 where + trace = traceShow + +instance Traceable Word64 where + trace = traceShow + +instance Traceable Bool where + trace = const Nothing + +instance Traceable ByteString where + trace = traceShow + +instance Traceable (MVar a) where + trace = const Nothing + +instance Traceable [Char] where + trace = traceShow + +instance Traceable IOException where + trace = traceShow + +-------------------------------------------------------------------------------- +-- IO instance for MonadS -- +-------------------------------------------------------------------------------- + +data TracedException = TracedException [String] SomeException + deriving Typeable + +instance Exception TracedException + +-- | Add tracing to 'IO' (see examples) +instance MonadS IO where + returnS = Prelude.return + bindS = \x f -> x Prelude.>>= \a -> catches (f a) (traceHandlers a) + failS = Prelude.fail + seqS = (Prelude.>>) + +instance Show TracedException where + show (TracedException ts ex) = + show ex ++ "\nTrace:\n" ++ unlines (map (\(i, t) -> show i ++ "\t" ++ t) (zip ([0..] :: [Int]) (take 10 . reverse $ ts))) + +traceHandlers :: Traceable a => a -> [Handler b] +traceHandlers a = case trace a of + Nothing -> [ Handler $ \ex -> throwIO (ex :: SomeException) ] + Just t -> [ Handler $ \(TracedException ts ex) -> throwIO $ TracedException (show t : ts) ex + , Handler $ \ex -> throwIO $ TracedException [show t] (ex :: SomeException) + ] + +-- | Definition of 'ifThenElse' for use with RebindableSyntax +ifThenElse :: Bool -> a -> a -> a +ifThenElse True x _ = x +ifThenElse False _ y = y diff --git a/packages/network-transport/ChangeLog b/packages/network-transport/ChangeLog new file mode 100644 index 00000000..beca2ec3 --- /dev/null +++ b/packages/network-transport/ChangeLog @@ -0,0 +1,81 @@ +2024-03-25 David Simmons-Duffin 0.5.7 + +* Bump bytestring and deepseq versions to build with GHC 9.8. + +2022-08-30 Facundo Domínguez 0.5.6 + +* Fix extension fields in the cabal file (#41). + +2022-08-09 Facundo Domínguez 0.5.5 + +* Relax dependency bounds to build with ghc9 (#40). + +2019-05-12 Facundo Domínguez 0.5.4 + +* Fix documentation typo (#39). + +2019-05-12 Facundo Domínguez 0.5.3 + +* Relax upper bound of hashable. + +2017-07-25 Facundo Domínguez 0.5.2 + +* prependLength checks for overflow (5608f0f) +* Drop inlinePerformIO for unsafeDupablePerformIO (18bf80c) +* Have travis build n-t even with no tests (7ffe43e) + +2017-02-23 Facundo Domínguez 0.5.1 + +* Add {encode|decode}{Word|Enum|Num}{32|16}. +* Removed {encode|decode}Int{32|16} + +2016-01-28 Facundo Domínguez 0.4.4.0 + +* Add compatibility with ghc-8. + +2016-01-28 Facundo Domínguez 0.4.3.0 + +* Derive Binary instances for missing types. +* Use auto-derive for Reliability as Binary instance. +* Stop testing with ghc-7.4 and build with ghc-7.10. + +2015-06-15 Facundo Domínguez 0.4.2.0 + +* Add NFData instance for EndPointAddress. +* Relax dependency bounds. + +2014-12-09 Tim Watson 0.4.1.0 + +* foreigns htonl, ntohl, htons, ntohs are imported from ws2_32 on windows +* Created Data instance for EndPointAddress (thanks Andrew Rademacher) + +2014-05-30 Tim Watson 0.4.0.0 + +* Fix build for GHC 7.4 - thanks mboes! +* Allow transformers above v5 +* Bump binary version to include 0.7.* +* Binary instance for 'Reliability' - thanks mboes! +* Hashable instance for 'EndPointAddress' + +2012-11-22 Edsko de Vries 0.3.0.1 + +* Relax bounds on Binary + +2012-10-03 Edsko de Vries 0.3.0 + +* Clarify disconnection +* Require that 'connect' be "as asynchronous as possible" +* Added strictness annotations + +2012-07-16 Edsko de Vries 0.2.0.2 + +* Base 4.6 compatible test suites +* Relax package constraints for bytestring + +2012-07-16 Edsko de Vries 0.2.0.1 + +* Hide catch only for base < 4.6 + +2012-07-07 Edsko de Vries 0.2.0 + +* Initial release. diff --git a/packages/network-transport/LICENSE b/packages/network-transport/LICENSE new file mode 100644 index 00000000..f3459e44 --- /dev/null +++ b/packages/network-transport/LICENSE @@ -0,0 +1,31 @@ +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. + diff --git a/packages/network-transport/network-transport.cabal b/packages/network-transport/network-transport.cabal new file mode 100644 index 00000000..e457eabf --- /dev/null +++ b/packages/network-transport/network-transport.cabal @@ -0,0 +1,98 @@ +cabal-version: 3.0 +Name: network-transport +Version: 0.5.7 +Build-Type: Simple +License: BSD-3-Clause +License-File: LICENSE +Copyright: Well-Typed LLP +Author: Duncan Coutts, Nicolas Wu, Edsko de Vries +maintainer: The Distributed Haskell team +Stability: experimental +Homepage: https://haskell-distributed.github.io +Bug-Reports: https://github.com/haskell-distributed/network-transport/issues +Synopsis: Network abstraction layer +Description: "Network.Transport" is a Network Abstraction Layer which provides + the following high-level concepts: + . + * Nodes in the network are represented by 'EndPoint's. These are + heavyweight stateful objects. + . + * Each 'EndPoint' has an 'EndPointAddress'. + . + * Connections can be established from one 'EndPoint' to another + using the 'EndPointAddress' of the remote end. + . + * The 'EndPointAddress' can be serialised and sent over the + network, whereas 'EndPoint's and connections cannot. + . + * Connections between 'EndPoint's are unidirectional and lightweight. + . + * Outgoing messages are sent via a 'Connection' object that + represents the sending end of the connection. + . + * Incoming messages for /all/ of the incoming connections on + an 'EndPoint' are collected via a shared receive queue. + . + * In addition to incoming messages, 'EndPoint's are notified of + other 'Event's such as new connections or broken connections. + . + This design was heavily influenced by the design of the Common + Communication Interface + (). + Important design goals are: + . + * Connections should be lightweight: it should be no problem to + create thousands of connections between endpoints. + . + * Error handling is explicit: every function declares as part of + its type which errors it can return (no exceptions are thrown) + . + * Error handling is "abstract": errors that originate from + implementation specific problems (such as "no more sockets" in + the TCP implementation) get mapped to generic errors + ("insufficient resources") at the Transport level. + . + This package provides the generic interface only; you will + probably also want to install at least one transport + implementation (network-transport-*). +tested-with: GHC==8.10.7 GHC==9.0.2 GHC==9.2.8 GHC==9.4.5 GHC==9.6.4 GHC==9.8.2 GHC==9.10.1 +Category: Network +extra-source-files: ChangeLog + +Source-Repository head + Type: git + Location: https://github.com/haskell-distributed/network-transport + +common warnings + ghc-options: -Wall + -Wcompat + -Widentities + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wredundant-constraints + -fhide-source-paths + -Wpartial-fields + +Library + import: warnings + Build-Depends: base >= 4.14 && < 5, + binary >= 0.8 && < 0.9, + bytestring >= 0.10 && < 0.13, + hashable >= 1.2.0.5 && < 1.6, + transformers >= 0.2 && < 0.7, + deepseq >= 1.0 && < 1.6 + Exposed-Modules: Network.Transport + Network.Transport.Util + Network.Transport.Internal + Other-Extensions: ForeignFunctionInterface + Default-Extensions: + RankNTypes, + ScopedTypeVariables, + DeriveDataTypeable, + GeneralizedNewtypeDeriving, + CPP + GHC-Options: -fno-warn-unused-do-bind + HS-Source-Dirs: src + Default-Language: Haskell2010 + if os(win32) + extra-libraries: ws2_32 diff --git a/packages/network-transport/src/Network/Transport.hs b/packages/network-transport/src/Network/Transport.hs new file mode 100644 index 00000000..fbe44112 --- /dev/null +++ b/packages/network-transport/src/Network/Transport.hs @@ -0,0 +1,288 @@ +{-# LANGUAGE DeriveGeneric #-} +-- | Network Transport +module Network.Transport + ( -- * Types + Transport(..) + , EndPoint(..) + , Connection(..) + , Event(..) + , ConnectionId + , Reliability(..) + , MulticastGroup(..) + , EndPointAddress(..) + , MulticastAddress(..) + -- * Hints + , ConnectHints(..) + , defaultConnectHints + -- * Error codes + , TransportError(..) + , NewEndPointErrorCode(..) + , ConnectErrorCode(..) + , NewMulticastGroupErrorCode(..) + , ResolveMulticastGroupErrorCode(..) + , SendErrorCode(..) + , EventErrorCode(..) + ) where + +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS (copy) +import qualified Data.ByteString.Char8 as BSC (unpack) +import Control.DeepSeq (NFData(rnf)) +import Control.Exception (Exception) +import Data.Typeable (Typeable) +import Data.Binary (Binary(..)) +import Data.Hashable +import Data.Word (Word64) +import Data.Data (Data) +import GHC.Generics (Generic) + +-------------------------------------------------------------------------------- +-- Main API -- +-------------------------------------------------------------------------------- + +-- | To create a network abstraction layer, use one of the +-- @Network.Transport.*@ packages. +data Transport = Transport { + -- | Create a new end point (heavyweight operation) + newEndPoint :: IO (Either (TransportError NewEndPointErrorCode) EndPoint) + -- | Shutdown the transport completely + , closeTransport :: IO () + } + +-- | Network endpoint. +data EndPoint = EndPoint { + -- | Endpoints have a single shared receive queue. + receive :: IO Event + -- | EndPointAddress of the endpoint. + , address :: EndPointAddress + -- | Create a new lightweight connection. + -- + -- 'connect' should be as asynchronous as possible; for instance, in + -- Transport implementations based on some heavy-weight underlying network + -- protocol (TCP, ssh), a call to 'connect' should be asynchronous when a + -- heavyweight connection has already been established. + , connect :: EndPointAddress -> Reliability -> ConnectHints -> IO (Either (TransportError ConnectErrorCode) Connection) + -- | Create a new multicast group. + , newMulticastGroup :: IO (Either (TransportError NewMulticastGroupErrorCode) MulticastGroup) + -- | Resolve an address to a multicast group. + , resolveMulticastGroup :: MulticastAddress -> IO (Either (TransportError ResolveMulticastGroupErrorCode) MulticastGroup) + -- | Close the endpoint + , closeEndPoint :: IO () + } + +-- | Lightweight connection to an endpoint. +data Connection = Connection { + -- | Send a message on this connection. + -- + -- 'send' provides vectored I/O, and allows multiple data segments to be + -- sent using a single call (cf. 'Network.Socket.ByteString.sendMany'). + -- Note that this segment structure is entirely unrelated to the segment + -- structure /returned/ by a 'Received' event. + send :: [ByteString] -> IO (Either (TransportError SendErrorCode) ()) + -- | Close the connection. + , close :: IO () + } + +-- | Event on an endpoint. +data Event = + -- | Received a message + Received {-# UNPACK #-} !ConnectionId [ByteString] + -- | Connection closed + | ConnectionClosed {-# UNPACK #-} !ConnectionId + -- | Connection opened + -- + -- 'ConnectionId's need not be allocated contiguously. + | ConnectionOpened {-# UNPACK #-} !ConnectionId Reliability EndPointAddress + -- | Received multicast + | ReceivedMulticast MulticastAddress [ByteString] + -- | The endpoint got closed (manually, by a call to closeEndPoint or closeTransport) + | EndPointClosed + -- | An error occurred + | ErrorEvent (TransportError EventErrorCode) + deriving (Show, Eq, Generic) + +instance Binary Event + +-- | Connection data ConnectHintsIDs enable receivers to distinguish one connection from another. +type ConnectionId = Word64 + +-- | Reliability guarantees of a connection. +data Reliability = + ReliableOrdered + | ReliableUnordered + | Unreliable + deriving (Show, Eq, Typeable, Generic) + +instance Binary Reliability +-- | Multicast group. +data MulticastGroup = MulticastGroup { + -- | EndPointAddress of the multicast group. + multicastAddress :: MulticastAddress + -- | Delete the multicast group completely. + , deleteMulticastGroup :: IO () + -- | Maximum message size that we can send to this group. + , maxMsgSize :: Maybe Int + -- | Send a message to the group. + , multicastSend :: [ByteString] -> IO () + -- | Subscribe to the given multicast group (to start receiving messages from the group). + , multicastSubscribe :: IO () + -- | Unsubscribe from the given multicast group (to stop receiving messages from the group). + , multicastUnsubscribe :: IO () + -- | Close the group (that is, indicate you no longer wish to send to the group). + , multicastClose :: IO () + } + +-- | EndPointAddress of an endpoint. +newtype EndPointAddress = EndPointAddress { endPointAddressToByteString :: ByteString } + deriving (Eq, Ord, Typeable, Data, Hashable) + +instance Binary EndPointAddress where + put = put . endPointAddressToByteString + get = EndPointAddress . BS.copy <$> get + +instance Show EndPointAddress where + show = BSC.unpack . endPointAddressToByteString + +instance NFData EndPointAddress where rnf x = x `seq` () + +-- | EndPointAddress of a multicast group. +newtype MulticastAddress = MulticastAddress { multicastAddressToByteString :: ByteString } + deriving (Eq, Ord, Generic) + +instance Binary MulticastAddress + +instance Show MulticastAddress where + show = show . multicastAddressToByteString + +-------------------------------------------------------------------------------- +-- Hints -- +-- -- +-- Hints provide transport-generic "suggestions". For now, these are -- +-- placeholders only. -- +-------------------------------------------------------------------------------- + +-- | Hints used by 'connect' +data ConnectHints = ConnectHints { + -- Timeout + connectTimeout :: Maybe Int + } + +-- | Default hints for connecting +defaultConnectHints :: ConnectHints +defaultConnectHints = ConnectHints { + connectTimeout = Nothing + } + +-------------------------------------------------------------------------------- +-- Error codes -- +-- -- +-- Errors should be transport-implementation independent. The deciding factor -- +-- for distinguishing one kind of error from another should be: might -- +-- application code have to take a different action depending on the kind of -- +-- error? -- +-------------------------------------------------------------------------------- + +-- | Errors returned by Network.Transport API functions consist of an error +-- code and a human readable description of the problem +data TransportError error = TransportError error String + deriving (Show, Typeable, Generic) + +instance (Binary error) => Binary (TransportError error) + +-- | Although the functions in the transport API never throw TransportErrors +-- (but return them explicitly), application code may want to turn these into +-- exceptions. +instance (Typeable err, Show err) => Exception (TransportError err) + +-- | When comparing errors we ignore the human-readable strings +instance Eq error => Eq (TransportError error) where + TransportError err1 _ == TransportError err2 _ = err1 == err2 + +-- | Errors during the creation of an endpoint +data NewEndPointErrorCode = + -- | Not enough resources + NewEndPointInsufficientResources + -- | Failed for some other reason + | NewEndPointFailed + deriving (Show, Typeable, Eq) + +-- | Connection failure +data ConnectErrorCode = + -- | Could not resolve the address + ConnectNotFound + -- | Insufficient resources (for instance, no more sockets available) + | ConnectInsufficientResources + -- | Timeout + | ConnectTimeout + -- | Failed for other reasons (including syntax error) + | ConnectFailed + deriving (Show, Typeable, Eq) + +-- | Failure during the creation of a new multicast group +data NewMulticastGroupErrorCode = + -- | Insufficient resources + NewMulticastGroupInsufficientResources + -- | Failed for some other reason + | NewMulticastGroupFailed + -- | Not all transport implementations support multicast + | NewMulticastGroupUnsupported + deriving (Show, Typeable, Eq) + +-- | Failure during the resolution of a multicast group +data ResolveMulticastGroupErrorCode = + -- | Multicast group not found + ResolveMulticastGroupNotFound + -- | Failed for some other reason (including syntax error) + | ResolveMulticastGroupFailed + -- | Not all transport implementations support multicast + | ResolveMulticastGroupUnsupported + deriving (Show, Typeable, Eq) + +-- | Failure during sending a message +data SendErrorCode = + -- | Connection was closed + SendClosed + -- | Send failed for some other reason + | SendFailed + deriving (Show, Typeable, Eq) + +-- | Error codes used when reporting errors to endpoints (through receive) +data EventErrorCode = + -- | Failure of the entire endpoint + EventEndPointFailed + -- | Transport-wide fatal error + | EventTransportFailed + -- | We lost connection to another endpoint + -- + -- Although "Network.Transport" provides multiple independent lightweight + -- connections between endpoints, those connections cannot /fail/ + -- independently: once one connection has failed, /all/ connections, in + -- both directions, must now be considered to have failed; they fail as a + -- "bundle" of connections, with only a single "bundle" of connections per + -- endpoint at any point in time. + -- + -- That is, suppose there are multiple connections in either direction + -- between endpoints A and B, and A receives a notification that it has + -- lost contact with B. Then A must not be able to send any further + -- messages to B on existing connections. + -- + -- Although B may not realize /immediately/ that its connection to A has + -- been broken, messages sent by B on existing connections should not be + -- delivered, and B must eventually get an EventConnectionLost message, + -- too. + -- + -- Moreover, this event must be posted before A has successfully + -- reconnected (in other words, if B notices a reconnection attempt from A, + -- it must post the EventConnectionLost before acknowledging the connection + -- from A) so that B will not receive events about new connections or + -- incoming messages from A without realizing that it got disconnected. + -- + -- If B attempts to establish another connection to A before it realized + -- that it got disconnected from A then it's okay for this connection + -- attempt to fail, and the EventConnectionLost to be posted at that point, + -- or for the EventConnectionLost to be posted and for the new connection + -- to be considered the first connection of the "new bundle". + | EventConnectionLost EndPointAddress + deriving (Show, Typeable, Eq, Generic) + +instance Binary EventErrorCode diff --git a/packages/network-transport/src/Network/Transport/Internal.hs b/packages/network-transport/src/Network/Transport/Internal.hs new file mode 100644 index 00000000..4c5c367d --- /dev/null +++ b/packages/network-transport/src/Network/Transport/Internal.hs @@ -0,0 +1,203 @@ +{-# LANGUAGE CPP #-} +-- | Internal functions +module Network.Transport.Internal + ( -- * Encoders/decoders + encodeWord32 + , decodeWord32 + , encodeEnum32 + , decodeNum32 + , encodeWord16 + , decodeWord16 + , encodeEnum16 + , decodeNum16 + , prependLength + -- * Miscellaneous abstractions + , mapIOException + , tryIO + , tryToEnum + , timeoutMaybe + , asyncWhenCancelled + -- * Replicated functionality from "base" + , void + , forkIOWithUnmask + -- * Debugging + , tlog + ) where + +import Foreign.Storable (pokeByteOff, peekByteOff) +import Foreign.ForeignPtr (withForeignPtr) +import Data.ByteString (ByteString) +import Data.List (foldl') +import qualified Data.ByteString as BS (length) +import qualified Data.ByteString.Internal as BSI + ( unsafeCreate + , toForeignPtr + ) +import Data.Word (Word32, Word16) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Exception + ( IOException + , SomeException + , AsyncException + , Exception + , catch + , try + , throw + , throwIO + , mask_ + ) +import Control.Concurrent (ThreadId, forkIO) +import Control.Concurrent.MVar (MVar, newEmptyMVar, takeMVar, putMVar) +import GHC.IO (unsafeUnmask) +import System.IO.Unsafe (unsafeDupablePerformIO) +import System.Timeout (timeout) +--import Control.Concurrent (myThreadId) + +#ifdef mingw32_HOST_OS + +foreign import stdcall unsafe "htonl" htonl :: Word32 -> Word32 +foreign import stdcall unsafe "ntohl" ntohl :: Word32 -> Word32 +foreign import stdcall unsafe "htons" htons :: Word16 -> Word16 +foreign import stdcall unsafe "ntohs" ntohs :: Word16 -> Word16 + +#else + +foreign import ccall unsafe "htonl" htonl :: Word32 -> Word32 +foreign import ccall unsafe "ntohl" ntohl :: Word32 -> Word32 +foreign import ccall unsafe "htons" htons :: Word16 -> Word16 +foreign import ccall unsafe "ntohs" ntohs :: Word16 -> Word16 + +#endif + +-- | Serialize 32-bit to network byte order +encodeWord32 :: Word32 -> ByteString +encodeWord32 w32 = + BSI.unsafeCreate 4 $ \p -> + pokeByteOff p 0 (htonl w32) + +-- | Deserialize 32-bit from network byte order +-- Throws an IO exception if this is not exactly 32 bits. +decodeWord32 :: ByteString -> Word32 +decodeWord32 bs + | BS.length bs /= 4 = throw $ userError "decodeWord32: not 4 bytes" + | otherwise = unsafeDupablePerformIO $ do + let (fp, offset, _) = BSI.toForeignPtr bs + withForeignPtr fp $ \p -> ntohl <$> peekByteOff p offset + +-- | Serialize 16-bit to network byte order +encodeWord16 :: Word16 -> ByteString +encodeWord16 w16 = + BSI.unsafeCreate 2 $ \p -> + pokeByteOff p 0 (htons w16) + +-- | Deserialize 16-bit from network byte order +-- Throws an IO exception if this is not exactly 16 bits. +decodeWord16 :: ByteString -> Word16 +decodeWord16 bs + | BS.length bs /= 2 = throw $ userError "decodeWord16: not 2 bytes" + | otherwise = unsafeDupablePerformIO $ do + let (fp, offset, _) = BSI.toForeignPtr bs + withForeignPtr fp $ \p -> ntohs <$> peekByteOff p offset + +-- | Encode an Enum in 32 bits by encoding its signed Int equivalent (beware +-- of truncation, an Enum may contain more than 2^32 points). +encodeEnum32 :: Enum a => a -> ByteString +encodeEnum32 = encodeWord32 . fromIntegral . fromEnum + +-- | Decode any Num type from 32 bits by using fromIntegral to convert from +-- a Word32. +decodeNum32 :: Num a => ByteString -> a +decodeNum32 = fromIntegral . decodeWord32 + +-- | Encode an Enum in 16 bits by encoding its signed Int equivalent (beware +-- of truncation, an Enum may contain more than 2^16 points). +encodeEnum16 :: Enum a => a -> ByteString +encodeEnum16 = encodeWord16 . fromIntegral . fromEnum + +-- | Decode any Num type from 16 bits by using fromIntegral to convert from +-- a Word16. +decodeNum16 :: Num a => ByteString -> a +decodeNum16 = fromIntegral . decodeWord16 + +-- | Prepend a list of bytestrings with their total length +-- Will be an exception in case of overflow: the sum of the lengths of +-- the ByteStrings overflows Int, or that sum overflows Word32. +prependLength :: [ByteString] -> [ByteString] +prependLength bss = case word32Length of + Nothing -> overflow + Just w32 -> encodeWord32 w32 : bss + where + intLength :: Int + intLength = foldl' safeAdd 0 . map BS.length $ bss + word32Length :: Maybe Word32 + word32Length = tryToEnum intLength + -- Non-negative integer addition with overflow check. + safeAdd :: Int -> Int -> Int + safeAdd i j + | r >= 0 = r + | otherwise = overflow + where + r = i + j + overflow = throw $ userError "prependLength: input is too long (overflow)" + +-- | Translate exceptions that arise in IO computations +mapIOException :: Exception e => (IOException -> e) -> IO a -> IO a +mapIOException f p = catch p (throwIO . f) + +-- | Like 'try', but lifted and specialized to IOExceptions +tryIO :: MonadIO m => IO a -> m (Either IOException a) +tryIO = liftIO . try + +-- | Logging (for debugging) +tlog :: MonadIO m => String -> m () +tlog _ = return () +{- +tlog msg = liftIO $ do + tid <- myThreadId + putStrLn $ show tid ++ ": " ++ msg +-} + +-- | Not all versions of "base" export 'void' +void :: Monad m => m a -> m () +void p = p >> return () + +-- | This was introduced in "base" some time after 7.0.4 +forkIOWithUnmask :: ((forall a . IO a -> IO a) -> IO ()) -> IO ThreadId +forkIOWithUnmask io = forkIO (io unsafeUnmask) + +-- | Safe version of 'toEnum' +tryToEnum :: (Enum a, Bounded a) => Int -> Maybe a +tryToEnum = go minBound maxBound + where + go :: Enum b => b -> b -> Int -> Maybe b + go lo hi n = if fromEnum lo <= n && n <= fromEnum hi then Just (toEnum n) else Nothing + +-- | If the timeout value is not Nothing, wrap the given computation with a +-- timeout and it if times out throw the specified exception. Identity +-- otherwise. +timeoutMaybe :: Exception e => Maybe Int -> e -> IO a -> IO a +timeoutMaybe Nothing _ f = f +timeoutMaybe (Just n) e f = do + ma <- timeout n f + case ma of + Nothing -> throwIO e + Just a -> return a + +-- | @asyncWhenCancelled g f@ runs f in a separate thread and waits for it +-- to complete. If f throws an exception we catch it and rethrow it in the +-- current thread. If the current thread is interrupted before f completes, +-- we run the specified clean up handler (if f throws an exception we assume +-- that no cleanup is necessary). +asyncWhenCancelled :: forall a. (a -> IO ()) -> IO a -> IO a +asyncWhenCancelled g f = mask_ $ do + mvar <- newEmptyMVar + forkIO $ try f >>= putMVar mvar + -- takeMVar is interruptible (even inside a mask_) + catch (takeMVar mvar) (exceptionHandler mvar) >>= either throwIO return + where + exceptionHandler :: MVar (Either SomeException a) + -> AsyncException + -> IO (Either SomeException a) + exceptionHandler mvar ex = do + forkIO $ takeMVar mvar >>= either (const $ return ()) g + throwIO ex diff --git a/packages/network-transport/src/Network/Transport/Util.hs b/packages/network-transport/src/Network/Transport/Util.hs new file mode 100644 index 00000000..243c6e2d --- /dev/null +++ b/packages/network-transport/src/Network/Transport/Util.hs @@ -0,0 +1,33 @@ +-- | Utility functions +-- +-- Note: this module is bound to change even more than the rest of the API :) +module Network.Transport.Util (spawn) where + +import Network.Transport + ( Transport + , EndPoint(..) + , EndPointAddress + , newEndPoint + ) +import Control.Exception (throwIO) +import Control.Concurrent (forkIO) +import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) + +-- | Fork a new thread, create a new end point on that thread, and run the specified IO operation on that thread. +-- +-- Returns the address of the new end point. +spawn :: Transport -> (EndPoint -> IO ()) -> IO EndPointAddress +spawn transport proc = do + addrMVar <- newEmptyMVar + forkIO $ do + mEndPoint <- newEndPoint transport + case mEndPoint of + Left err -> + putMVar addrMVar (Left err) + Right endPoint -> do + putMVar addrMVar (Right (address endPoint)) + proc endPoint + mAddr <- takeMVar addrMVar + case mAddr of + Left err -> throwIO err + Right addr -> return addr diff --git a/packages/network-transport/tests/chat/ChatClient.hs b/packages/network-transport/tests/chat/ChatClient.hs new file mode 100644 index 00000000..69a97468 --- /dev/null +++ b/packages/network-transport/tests/chat/ChatClient.hs @@ -0,0 +1,107 @@ +import System.Environment (getArgs) +import Network.Transport +import Network.Transport.TCP (createTransport) +import Control.Concurrent.MVar (MVar, newEmptyMVar, takeMVar, putMVar, newMVar, readMVar, modifyMVar_, modifyMVar) +import Control.Concurrent (forkIO) +import Control.Monad (forever, forM, unless, when) +import qualified Data.ByteString as BS (concat, null) +import qualified Data.ByteString.Char8 as BSC (pack, unpack, getLine) +import Data.Map (Map) +import qualified Data.Map as Map (fromList, elems, insert, member, empty, size, delete, (!)) + +chatClient :: MVar () -> EndPoint -> EndPointAddress -> IO () +chatClient done endpoint serverAddr = do + connect endpoint serverAddr ReliableOrdered + cOut <- getPeers >>= connectToPeers + cIn <- newMVar Map.empty + + -- Listen for incoming messages + forkIO . forever $ do + event <- receive endpoint + case event of + Received _ msg -> + putStrLn . BSC.unpack . BS.concat $ msg + ConnectionOpened cid _ addr -> do + modifyMVar_ cIn $ return . Map.insert cid addr + didAdd <- modifyMVar cOut $ \conns -> + if not (Map.member addr conns) + then do + Right conn <- connect endpoint addr ReliableOrdered + return (Map.insert addr conn conns, True) + else + return (conns, False) + when didAdd $ showNumPeers cOut + ConnectionClosed cid -> do + addr <- modifyMVar cIn $ \conns -> + return (Map.delete cid conns, conns Map.! cid) + modifyMVar_ cOut $ \conns -> do + close (conns Map.! addr) + return (Map.delete addr conns) + showNumPeers cOut + + + +{- + chatState <- newMVar (Map.fromList peerConns) + + -- Thread to listen to incoming messages + forkIO . forever $ do + event <- receive endpoint + case event of + ConnectionOpened _ _ (EndPointAddress addr) -> do + modifyMVar_ chatState $ \peers -> + if not (Map.member addr peers) + then do + Right conn <- connect endpoint (EndPointAddress addr) ReliableOrdered + return (Map.insert addr conn peers) + else + return peers + Received _ msg -> + putStrLn . BSC.unpack . BS.concat $ msg + ConnectionClosed _ -> + return () + +-} + -- Thread to interact with the user + showNumPeers cOut + let go = do + msg <- BSC.getLine + unless (BS.null msg) $ do + readMVar cOut >>= \conns -> forM (Map.elems conns) $ \conn -> send conn [msg] + go + go + putMVar done () + + where + getPeers :: IO [EndPointAddress] + getPeers = do + ConnectionOpened _ _ _ <- receive endpoint + Received _ msg <- receive endpoint + ConnectionClosed _ <- receive endpoint + return . map EndPointAddress . read . BSC.unpack . BS.concat $ msg + + connectToPeers :: [EndPointAddress] -> IO (MVar (Map EndPointAddress Connection)) + connectToPeers addrs = do + conns <- forM addrs $ \addr -> do + Right conn <- connect endpoint addr ReliableOrdered + return (addr, conn) + newMVar (Map.fromList conns) + + showNumPeers :: MVar (Map EndPointAddress Connection) -> IO () + showNumPeers cOut = + readMVar cOut >>= \conns -> putStrLn $ "# " ++ show (Map.size conns) ++ " peers" + + + + +main :: IO () +main = do + host:port:server:_ <- getArgs + Right transport <- createTransport host port + Right endpoint <- newEndPoint transport + clientDone <- newEmptyMVar + + forkIO $ chatClient clientDone endpoint (EndPointAddress . BSC.pack $ server) + + takeMVar clientDone + diff --git a/packages/network-transport/tests/chat/ChatServer.hs b/packages/network-transport/tests/chat/ChatServer.hs new file mode 100644 index 00000000..7c36df00 --- /dev/null +++ b/packages/network-transport/tests/chat/ChatServer.hs @@ -0,0 +1,28 @@ +import System.Environment (getArgs) +import Network.Transport +import Network.Transport.TCP (createTransport) +import Control.Monad.State (evalStateT, modify, get) +import Control.Monad (forever) +import Control.Monad.IO.Class (liftIO) +import qualified Data.IntMap as IntMap (empty, insert, delete, elems) +import qualified Data.ByteString.Char8 as BSC (pack) + +main :: IO () +main = do + host:port:_ <- getArgs + Right transport <- createTransport host port + Right endpoint <- newEndPoint transport + + putStrLn $ "Chat server ready at " ++ (show . endPointAddressToByteString . address $ endpoint) + + flip evalStateT IntMap.empty . forever $ do + event <- liftIO $ receive endpoint + case event of + ConnectionOpened cid _ addr -> do + get >>= \clients -> liftIO $ do + Right conn <- connect endpoint addr ReliableOrdered + send conn [BSC.pack . show . IntMap.elems $ clients] + close conn + modify $ IntMap.insert cid (endPointAddressToByteString addr) + ConnectionClosed cid -> + modify $ IntMap.delete cid diff --git a/packages/network-transport/tests/sumeuler/SumEulerMaster.hs b/packages/network-transport/tests/sumeuler/SumEulerMaster.hs new file mode 100644 index 00000000..45e921c6 --- /dev/null +++ b/packages/network-transport/tests/sumeuler/SumEulerMaster.hs @@ -0,0 +1,44 @@ +import System.Environment (getArgs) +import Network.Transport +import Network.Transport.TCP (createTransport) +import Control.Concurrent (forkIO) +import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar) +import Control.Monad (forM, forM_, replicateM_) +import qualified Data.ByteString as BS (concat) +import qualified Data.ByteString.Char8 as BSC (pack, unpack) +import Control.Monad.Trans.Writer (execWriterT, tell) +import Control.Monad.IO.Class (liftIO) + +master :: MVar () -> EndPoint -> [String] -> IO () +master done endpoint workers = do + conns <- forM workers $ \worker -> do + Right conn <- connect endpoint (EndPointAddress $ BSC.pack worker) ReliableOrdered + return conn + -- Send out requests + forM_ conns $ \conn -> do + send conn [BSC.pack $ show 5300] + close conn + -- Print all replies + replies <- execWriterT $ replicateM_ (length workers * 3) $ do + event <- liftIO $ receive endpoint + case event of + Received _ msg -> + tell [read . BSC.unpack . BS.concat $ msg] + _ -> + return () + putStrLn $ "Replies: " ++ show (replies :: [Int]) + putMVar done () + +main :: IO () +main = do + host:port:workers <- getArgs + Right transport <- createTransport host port + Right endpoint <- newEndPoint transport + masterDone <- newEmptyMVar + + putStrLn $ "Master using workers " ++ show workers + + forkIO $ master masterDone endpoint workers + + takeMVar masterDone + diff --git a/packages/network-transport/tests/sumeuler/SumEulerWorker.hs b/packages/network-transport/tests/sumeuler/SumEulerWorker.hs new file mode 100644 index 00000000..d65b8a60 --- /dev/null +++ b/packages/network-transport/tests/sumeuler/SumEulerWorker.hs @@ -0,0 +1,52 @@ +import System.Environment (getArgs) +import Network.Transport +import Network.Transport.TCP (createTransport) +import qualified Data.ByteString.Char8 as BSC (putStrLn, pack, unpack) +import qualified Data.ByteString as BS (concat) +import Control.Concurrent (forkIO) +import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar) +import System.IO (hFlush, stdout, stderr, hPutStrLn) + +mkList :: Int -> [Int] +mkList n = [1 .. n - 1] + +relPrime :: Int -> Int -> Bool +relPrime x y = gcd x y == 1 + +euler :: Int -> Int +euler n = length (filter (relPrime n) (mkList n)) + +sumEuler :: Int -> Int +sumEuler = sum . (map euler) . mkList + +worker :: String -> MVar () -> EndPoint -> IO () +worker id done endpoint = do + ConnectionOpened _ _ theirAddr <- receive endpoint + Right replyChan <- connect endpoint theirAddr ReliableOrdered + go replyChan + where + go replyChan = do + event <- receive endpoint + case event of + ConnectionClosed _ -> do + close replyChan + putMVar done () + Received _ msg -> do + let i :: Int + i = read . BSC.unpack . BS.concat $ msg + send replyChan [BSC.pack . show $ sumEuler i] + go replyChan + +main :: IO () +main = do + (id:host:port:_) <- getArgs + Right transport <- createTransport host port + Right endpoint <- newEndPoint transport + workerDone <- newEmptyMVar + + BSC.putStrLn (endPointAddressToByteString (address endpoint)) + hFlush stdout + + forkIO $ worker id workerDone endpoint + + takeMVar workerDone diff --git a/packages/network-transport/tests/sumeuler/sumeuler.sh b/packages/network-transport/tests/sumeuler/sumeuler.sh new file mode 100755 index 00000000..d5790b0d --- /dev/null +++ b/packages/network-transport/tests/sumeuler/sumeuler.sh @@ -0,0 +1,20 @@ +#/bin/bash + +rm -f workers +killall -9 SumEulerWorker + +ghc -O2 -i../src -XScopedTypeVariables SumEulerWorker +ghc -O2 -i../src -XScopedTypeVariables SumEulerMaster + +./SumEulerWorker 1 127.0.0.1 8080 >> workers & +./SumEulerWorker 1 127.0.0.1 8081 >> workers & +./SumEulerWorker 1 127.0.0.1 8082 >> workers & +./SumEulerWorker 1 127.0.0.1 8083 >> workers & +./SumEulerWorker 1 127.0.0.1 8084 >> workers & +./SumEulerWorker 1 127.0.0.1 8085 >> workers & +./SumEulerWorker 1 127.0.0.1 8086 >> workers & +./SumEulerWorker 1 127.0.0.1 8087 >> workers & + +echo "Waiting for all workers to be ready" +sleep 1 +cat workers | xargs ./SumEulerMaster 127.0.0.1 8090 diff --git a/packages/rank1dynamic/ChangeLog b/packages/rank1dynamic/ChangeLog new file mode 100644 index 00000000..3a601a60 --- /dev/null +++ b/packages/rank1dynamic/ChangeLog @@ -0,0 +1,44 @@ +2020-10-24 Facundo Domínguez 0.4.1 + +* Support ghc-8.6.5 and ghc-8.8.4 + +2017-08-22 Facundo Domínguez 0.4.0 + +* Add compatibility with ghc-8.2.1. +* Drop support for ghc-7.6 and ghc-7.8. + +2016-05-31 Facundo Domínguez 0.3.3.0 + +* Add compatibility with ghc-8. +* Update bug report url in cabal file. + +2016-02-18 Facundo Domínguez 0.3.2.0 + +* Stop testing ghc-7.4 and test ghc-7.10. +* Add unsafeToDynamic. + +2016-01-25 Facundo Domínguez 0.3.1.1 + +* Push HUnit upper bound. + +2015-06-15 Facundo Domínguez 0.2.1.0 + +* Loosen upper bound of ghc-prim. + +2014-05-30 Tim Watson 0.2.0.0 + +* Fix funResultTy so @funResultTy ANY _ = ANY@ +* Ensure the result of funResultTy is consistent with unification +* Bump binary version to include 0.7.* + +2012-11-22 Edsko de Vries 0.1.0.2 + +* Relax package bounds to allow for Binary 0.6 + +2012-09-27 Edsko de Vries 0.1.0.1 + +* Relax lower bound of base to 4.4 (ghc 7.2) + +2012-08-10 Edsko de Vries 0.1.0.0 + +* Initial release. diff --git a/packages/rank1dynamic/LICENSE b/packages/rank1dynamic/LICENSE new file mode 100644 index 00000000..08423c07 --- /dev/null +++ b/packages/rank1dynamic/LICENSE @@ -0,0 +1,31 @@ +Copyright (c) 2012, Edsko de Vries +Copyright (c) 2015, Tweag I/O Limited + +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. diff --git a/packages/rank1dynamic/rank1dynamic.cabal b/packages/rank1dynamic/rank1dynamic.cabal new file mode 100644 index 00000000..de667cdf --- /dev/null +++ b/packages/rank1dynamic/rank1dynamic.cabal @@ -0,0 +1,55 @@ +cabal-version: 3.0 +Name: rank1dynamic +Version: 0.4.1 +Synopsis: Like Data.Dynamic/Data.Typeable but with support for rank-1 polymorphic types +Description: "Data.Typeable" and "Data.Dynamic" only support monomorphic types. + In this package we provide similar functionality but with + support for rank-1 polymorphic types. +Homepage: http://haskell-distributed.github.com +License: BSD-3-Clause +License-File: LICENSE +Author: Edsko de Vries +maintainer: The Distributed Haskell team +Bug-Reports: https://github.com/haskell-distributed/rank1dynamic/issues +Copyright: Well-Typed LLP, Tweag I/O Limited +Category: Data +Build-Type: Simple +extra-source-files: ChangeLog + +Source-Repository head + Type: git + Location: https://github.com/haskell-distributed/rank1dynamic + +common warnings + ghc-options: -Wall + -Wcompat + -Widentities + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wredundant-constraints + -fhide-source-paths + -Wpartial-fields + +Library + import: warnings + Exposed-Modules: Data.Rank1Dynamic, + Data.Rank1Typeable + Build-Depends: base >= 4.14 && < 5, + binary >= 0.8 && < 0.9 + HS-Source-Dirs: src + default-language: Haskell2010 + Default-Extensions: EmptyDataDecls, + DeriveDataTypeable, + ViewPatterns + +Test-Suite TestRank1Dynamic + import: warnings + Type: exitcode-stdio-1.0 + Main-Is: test.hs + Build-Depends: base >= 4.14 && < 5, + HUnit >= 1.2 && < 1.7, + rank1dynamic, + test-framework >= 0.6 && < 0.9, + test-framework-hunit >= 0.2.0 && < 0.4 + default-language: Haskell2010 + HS-Source-Dirs: tests diff --git a/packages/rank1dynamic/src/Data/Rank1Dynamic.hs b/packages/rank1dynamic/src/Data/Rank1Dynamic.hs new file mode 100644 index 00000000..d6d0bef5 --- /dev/null +++ b/packages/rank1dynamic/src/Data/Rank1Dynamic.hs @@ -0,0 +1,130 @@ +-- | Dynamic values with support for rank-1 polymorphic types. +-- +-- [Examples of fromDynamic] +-- +-- These examples correspond to the 'Data.Rank1Typeable.isInstanceOf' examples +-- in "Data.Rank1Typeable". +-- +-- > > do f <- fromDynamic (toDynamic (even :: Int -> Bool)) ; return $ (f :: Int -> Int) 0 +-- > Left "Cannot unify Int and Bool" +-- > +-- > > do f <- fromDynamic (toDynamic (const 1 :: ANY -> Int)) ; return $ (f :: Int -> Int) 0 +-- > Right 1 +-- > +-- > > do f <- fromDynamic (toDynamic (unsafeCoerce :: ANY1 -> ANY2)) ; return $ (f :: Int -> Int) 0 +-- > Right 0 +-- > +-- > > do f <- fromDynamic (toDynamic (id :: ANY -> ANY)) ; return $ (f :: Int -> Bool) 0 +-- > Left "Cannot unify Bool and Int" +-- > +-- > > do f <- fromDynamic (toDynamic (undefined :: ANY)) ; return $ (f :: Int -> Int) 0 +-- > Right *** Exception: Prelude.undefined +-- > +-- > > do f <- fromDynamic (toDynamic (id :: ANY -> ANY)) ; return $ (f :: Int) +-- > Left "Cannot unify Int and ->" +-- +-- [Examples of dynApply] +-- +-- These examples correspond to the 'Data.Rank1Typeable.funResultTy' examples +-- in "Data.Rank1Typeable". +-- +-- > > do app <- toDynamic (id :: ANY -> ANY) `dynApply` toDynamic True ; f <- fromDynamic app ; return $ (f :: Bool) +-- > Right True +-- > +-- > > do app <- toDynamic (const :: ANY -> ANY1 -> ANY) `dynApply` toDynamic True ; f <- fromDynamic app ; return $ (f :: Int -> Bool) 0 +-- > Right True +-- > +-- > > do app <- toDynamic (($ True) :: (Bool -> ANY) -> ANY) `dynApply` toDynamic (id :: ANY -> ANY) ; f <- fromDynamic app ; return (f :: Bool) +-- > Right True +-- > +-- > > app <- toDynamic (const :: ANY -> ANY1 -> ANY) `dynApply` toDynamic (id :: ANY -> ANY) ; f <- fromDynamic app ; return $ (f :: Int -> Bool -> Bool) 0 True +-- > Right True +-- > +-- > > do app <- toDynamic ((\f -> f . f) :: (ANY -> ANY) -> ANY -> ANY) `dynApply` toDynamic (even :: Int -> Bool) ; f <- fromDynamic app ; return (f :: ()) +-- > Left "Cannot unify Int and Bool" +-- +-- [Using toDynamic] +-- +-- When using polymorphic values you need to give an explicit type annotation: +-- +-- > > toDynamic id +-- > +-- > :46:1: +-- > Ambiguous type variable `a0' in the constraint: +-- > (Typeable a0) arising from a use of `toDynamic' +-- > Probable fix: add a type signature that fixes these type variable(s) +-- > In the expression: toDynamic id +-- > In an equation for `it': it = toDynamic id +-- +-- versus +-- +-- > > toDynamic (id :: ANY -> ANY) +-- > < ANY>> +-- +-- Note that these type annotation are checked by ghc like any other: +-- +-- > > toDynamic (id :: ANY -> ANY1) +-- > +-- > :45:12: +-- > Couldn't match expected type `V1' with actual type `V0' +-- > Expected type: ANY -> ANY1 +-- > Actual type: ANY -> ANY +-- > In the first argument of `toDynamic', namely `(id :: ANY -> ANY1)' +-- > In the expression: toDynamic (id :: ANY -> ANY1) +module Data.Rank1Dynamic + ( Dynamic + , toDynamic + , fromDynamic + , TypeError + , dynTypeRep + , dynApply + , unsafeToDynamic + ) where + +import qualified GHC.Exts as GHC (Any) +import Data.Rank1Typeable + ( Typeable + , TypeRep + , typeOf + , isInstanceOf + , TypeError + , funResultTy + ) +import Unsafe.Coerce (unsafeCoerce) + +-- | Encapsulate an object and its type +data Dynamic = Dynamic TypeRep GHC.Any + +instance Show Dynamic where + showsPrec _ (Dynamic t _) = showString "<<" . shows t . showString ">>" + +-- | Introduce a dynamic value +toDynamic :: Typeable a => a -> Dynamic +toDynamic x = Dynamic (typeOf x) (unsafeCoerce x) + +-- | Construct a dynamic value with a user-supplied type rep +-- +-- This function is unsafe because we have no way of verifying that the +-- provided type representation matches the value. +-- +-- Since 0.3.2.0. +unsafeToDynamic :: TypeRep -> a -> Dynamic +unsafeToDynamic typ x = Dynamic typ (unsafeCoerce x) + +-- | Eliminate a dynamic value +fromDynamic :: Typeable a => Dynamic -> Either TypeError a +fromDynamic (Dynamic t v) = + case unsafeCoerce v of + r -> case typeOf r `isInstanceOf` t of + Left err -> Left err + Right () -> Right r + +-- | Apply one dynamic value to another +dynApply :: Dynamic -> Dynamic -> Either TypeError Dynamic +dynApply (Dynamic t1 f) (Dynamic t2 x) = do + t3 <- funResultTy t1 t2 + return $ Dynamic t3 (unsafeCoerce f x) + +-- | The type representation of a dynamic value +dynTypeRep :: Dynamic -> TypeRep +dynTypeRep (Dynamic t _) = t diff --git a/packages/rank1dynamic/src/Data/Rank1Typeable.hs b/packages/rank1dynamic/src/Data/Rank1Typeable.hs new file mode 100644 index 00000000..e533bb14 --- /dev/null +++ b/packages/rank1dynamic/src/Data/Rank1Typeable.hs @@ -0,0 +1,385 @@ +-- | Runtime type representation of terms with support for rank-1 polymorphic +-- types with type variables of kind *. +-- +-- The essence of this module is that we use the standard 'Typeable' +-- representation of "Data.Typeable" but we introduce a special (empty) data +-- type 'TypVar' which represents type variables. 'TypVar' is indexed by an +-- arbitrary other data type, giving you an unbounded number of type variables; +-- for convenience, we define 'ANY', 'ANY1', .., 'ANY9'. +-- +-- [Examples of isInstanceOf] +-- +-- > -- We CANNOT use a term of type 'Int -> Bool' as 'Int -> Int' +-- > > typeOf (undefined :: Int -> Int) `isInstanceOf` typeOf (undefined :: Int -> Bool) +-- > Left "Cannot unify Int and Bool" +-- > +-- > -- We CAN use a term of type 'forall a. a -> Int' as 'Int -> Int' +-- > > typeOf (undefined :: Int -> Int) `isInstanceOf` typeOf (undefined :: ANY -> Int) +-- > Right () +-- > +-- > -- We CAN use a term of type 'forall a b. a -> b' as 'forall a. a -> a' +-- > > typeOf (undefined :: ANY -> ANY) `isInstanceOf` typeOf (undefined :: ANY -> ANY1) +-- > Right () +-- > +-- > -- We CANNOT use a term of type 'forall a. a -> a' as 'forall a b. a -> b' +-- > > typeOf (undefined :: ANY -> ANY1) `isInstanceOf` typeOf (undefined :: ANY -> ANY) +-- > Left "Cannot unify Succ and Zero" +-- > +-- > -- We CAN use a term of type 'forall a. a' as 'forall a. a -> a' +-- > > typeOf (undefined :: ANY -> ANY) `isInstanceOf` typeOf (undefined :: ANY) +-- > Right () +-- > +-- > -- We CANNOT use a term of type 'forall a. a -> a' as 'forall a. a' +-- > > typeOf (undefined :: ANY) `isInstanceOf` typeOf (undefined :: ANY -> ANY) +-- > Left "Cannot unify Skolem and ->" +-- +-- (Admittedly, the quality of the type errors could be improved.) +-- +-- [Examples of funResultTy] +-- +-- > -- Apply fn of type (forall a. a -> a) to arg of type Bool gives Bool +-- > > funResultTy (typeOf (undefined :: ANY -> ANY)) (typeOf (undefined :: Bool)) +-- > Right Bool +-- > +-- > -- Apply fn of type (forall a b. a -> b -> a) to arg of type Bool gives forall a. a -> Bool +-- > > funResultTy (typeOf (undefined :: ANY -> ANY1 -> ANY)) (typeOf (undefined :: Bool)) +-- > Right (ANY -> Bool) -- forall a. a -> Bool +-- > +-- > -- Apply fn of type (forall a. (Bool -> a) -> a) to argument of type (forall a. a -> a) gives Bool +-- > > funResultTy (typeOf (undefined :: (Bool -> ANY) -> ANY)) (typeOf (undefined :: ANY -> ANY)) +-- > Right Bool +-- > +-- > -- Apply fn of type (forall a b. a -> b -> a) to arg of type (forall a. a -> a) gives (forall a b. a -> b -> b) +-- > > funResultTy (typeOf (undefined :: ANY -> ANY1 -> ANY)) (typeOf (undefined :: ANY1 -> ANY1)) +-- > Right (ANY -> ANY1 -> ANY1) +-- > +-- > -- Cannot apply function of type (forall a. (a -> a) -> a -> a) to arg of type (Int -> Bool) +-- > > funResultTy (typeOf (undefined :: (ANY -> ANY) -> (ANY -> ANY))) (typeOf (undefined :: Int -> Bool)) +-- > Left "Cannot unify Int and Bool" +{-# LANGUAGE BangPatterns #-} +module Data.Rank1Typeable + ( -- * Basic types + TypeRep + , typeOf + , splitTyConApp + , mkTyConApp + -- * Operations on type representations + , isInstanceOf + , funResultTy + , TypeError + -- * Type variables + , TypVar + , Zero + , Succ + , V0 + , V1 + , V2 + , V3 + , V4 + , V5 + , V6 + , V7 + , V8 + , V9 + , ANY + , ANY1 + , ANY2 + , ANY3 + , ANY4 + , ANY5 + , ANY6 + , ANY7 + , ANY8 + , ANY9 + -- * Re-exports from Typeable + , Typeable + ) where + +import Prelude hiding (succ) +import Control.Arrow ((***), second) +import Control.Monad (void) +import Data.Binary +import Data.Function (on) +import Data.List (intersperse, isPrefixOf) +import Data.Maybe (fromMaybe) +import Data.Typeable ( Typeable ) +import qualified Data.Typeable as T +import GHC.Fingerprint + +tcList, tcFun :: TyCon +tcList = fst $ splitTyConApp $ typeOf [()] +tcFun = fst $ splitTyConApp $ typeOf (\() -> ()) + +-------------------------------------------------------------------------------- +-- The basic type -- +-------------------------------------------------------------------------------- + +-- | Dynamic type representation with support for rank-1 types +data TypeRep + = TRCon TyCon + | TRApp {-# UNPACK #-} !Fingerprint TypeRep TypeRep + +data TyCon = TyCon + { tyConFingerprint :: {-# UNPACK #-} !Fingerprint + , tyConPackage :: String + , tyConModule :: String + , tyConName :: String + } + +-- | The fingerprint of a TypeRep +typeRepFingerprint :: TypeRep -> Fingerprint +typeRepFingerprint (TRCon c) = tyConFingerprint c +typeRepFingerprint (TRApp fp _ _) = fp + +-- | Compare two type representations +instance Eq TyCon where + (==) = (==) `on` tyConFingerprint + +instance Eq TypeRep where + (==) = (==) `on` typeRepFingerprint + +--- Binary instance for 'TypeRep', avoiding orphan instances +instance Binary TypeRep where + put (splitTyConApp -> (tc, ts)) = do + put $ tyConPackage tc + put $ tyConModule tc + put $ tyConName tc + put ts + get = do + package <- get + modul <- get + name <- get + ts <- get + return $ mkTyConApp (mkTyCon3 package modul name) ts + +-- | The type representation of any 'Typeable' term +typeOf :: Typeable a => a -> TypeRep +typeOf = trTypeOf . T.typeOf + +-- | Conversion from Data.Typeable.TypeRep to Data.Rank1Typeable.TypeRep +trTypeOf :: T.TypeRep -> TypeRep +trTypeOf t = let (c, ts) = T.splitTyConApp t + in foldl mkTRApp (TRCon $ fromTypeableTyCon c) $ map trTypeOf ts + where + fromTypeableTyCon c = + TyCon (T.tyConFingerprint c) + (T.tyConPackage c) + (T.tyConModule c) + (T.tyConName c) + +-- | Applies a TypeRep to another. +mkTRApp :: TypeRep -> TypeRep -> TypeRep +mkTRApp t0 t1 = TRApp fp t0 t1 + where + fp = fingerprintFingerprints [typeRepFingerprint t0, typeRepFingerprint t1] + +mkTyCon3 :: String -> String -> String -> TyCon +mkTyCon3 pkg m name = TyCon fp pkg m name + where + fp = fingerprintFingerprints [ fingerprintString s | s <- [pkg, m, name] ] + +-------------------------------------------------------------------------------- +-- Constructors/destructors (views) -- +-------------------------------------------------------------------------------- + +-- | Split a type representation into the application of +-- a type constructor and its argument +splitTyConApp :: TypeRep -> (TyCon, [TypeRep]) +splitTyConApp = go [] + where + go xs (TRCon c) = (c, xs) + go xs (TRApp _ t0 t1) = go (t1 : xs) t0 + +-- | Inverse of 'splitTyConApp' +mkTyConApp :: TyCon -> [TypeRep] -> TypeRep +mkTyConApp c = foldl mkTRApp (TRCon c) + +isTypVar :: TypeRep -> Maybe Var +isTypVar (splitTyConApp -> (c, [t])) | c == typVar = Just t +isTypVar _ = Nothing + +mkTypVar :: Var -> TypeRep +mkTypVar x = mkTyConApp typVar [x] + +typVar :: TyCon +typVar = let (c, _) = splitTyConApp (typeOf (undefined :: TypVar V0)) in c + +skolem :: TyCon +skolem = let (c, _) = splitTyConApp (typeOf (undefined :: Skolem V0)) in c + +-------------------------------------------------------------------------------- +-- Type variables -- +-------------------------------------------------------------------------------- + +data TypVar a deriving Typeable +data Skolem a deriving Typeable +data Zero deriving Typeable +data Succ a deriving Typeable + +type V0 = Zero +type V1 = Succ V0 +type V2 = Succ V1 +type V3 = Succ V2 +type V4 = Succ V3 +type V5 = Succ V4 +type V6 = Succ V5 +type V7 = Succ V6 +type V8 = Succ V7 +type V9 = Succ V8 + +type ANY = TypVar V0 +type ANY1 = TypVar V1 +type ANY2 = TypVar V2 +type ANY3 = TypVar V3 +type ANY4 = TypVar V4 +type ANY5 = TypVar V5 +type ANY6 = TypVar V6 +type ANY7 = TypVar V7 +type ANY8 = TypVar V8 +type ANY9 = TypVar V9 + +-------------------------------------------------------------------------------- +-- Operations on type reps -- +-------------------------------------------------------------------------------- + +-- | If 'isInstanceOf' fails it returns a type error +type TypeError = String + +-- | @t1 `isInstanceOf` t2@ checks if @t1@ is an instance of @t2@ +isInstanceOf :: TypeRep -> TypeRep -> Either TypeError () +isInstanceOf t1 t2 = void (unify (skolemize t1) t2) + +-- | @funResultTy t1 t2@ is the type of the result when applying a function +-- of type @t1@ to an argument of type @t2@ +funResultTy :: TypeRep -> TypeRep -> Either TypeError TypeRep +funResultTy t1 t2 = do + let anyTy = mkTypVar $ typeOf (undefined :: V0) + s <- unify (alphaRename "f" t1) $ mkTyConApp tcFun [alphaRename "x" t2, anyTy] + return $ normalize $ subst s anyTy + +-------------------------------------------------------------------------------- +-- Alpha-renaming and normalization -- +-------------------------------------------------------------------------------- + +alphaRename :: String -> TypeRep -> TypeRep +alphaRename prefix (isTypVar -> Just x) = + mkTypVar (mkTyConApp (mkTyCon prefix) [x]) +alphaRename prefix (splitTyConApp -> (c, ts)) = + mkTyConApp c (map (alphaRename prefix) ts) + +tvars :: TypeRep -> [Var] +tvars (isTypVar -> Just x) = [x] +tvars (splitTyConApp -> (_, ts)) = concatMap tvars ts + +normalize :: TypeRep -> TypeRep +normalize t = subst (zip (tvars t) anys) t + where + anys :: [TypeRep] + anys = map mkTypVar (iterate succ zero) + + succ :: TypeRep -> TypeRep + succ = mkTyConApp succTyCon . (:[]) + + zero :: TypeRep + zero = mkTyConApp zeroTyCon [] + +mkTyCon :: String -> TyCon +mkTyCon = mkTyCon3 "rank1typeable" "Data.Rank1Typeable" + +succTyCon :: TyCon +succTyCon = let (c, _) = splitTyConApp (typeOf (undefined :: Succ Zero)) in c + +zeroTyCon :: TyCon +zeroTyCon = let (c, _) = splitTyConApp (typeOf (undefined :: Zero)) in c + +-------------------------------------------------------------------------------- +-- Unification -- +-------------------------------------------------------------------------------- + +type Substitution = [(Var, TypeRep)] +type Equation = (TypeRep, TypeRep) +type Var = TypeRep + +skolemize :: TypeRep -> TypeRep +skolemize (isTypVar -> Just x) = mkTyConApp skolem [x] +skolemize (splitTyConApp -> (c, ts)) = mkTyConApp c (map skolemize ts) + +occurs :: Var -> TypeRep -> Bool +occurs x (isTypVar -> Just x') = x == x' +occurs x (splitTyConApp -> (_, ts)) = any (occurs x) ts + +subst :: Substitution -> TypeRep -> TypeRep +subst s (isTypVar -> Just x) = fromMaybe (mkTypVar x) (lookup x s) +subst s (splitTyConApp -> (c, ts)) = mkTyConApp c (map (subst s) ts) + +unify :: TypeRep + -> TypeRep + -> Either TypeError Substitution +unify = \t1 t2 -> go [] [(t1, t2)] + where + go :: Substitution + -> [Equation] + -> Either TypeError Substitution + go acc [] = + return acc + go acc ((t1, t2) : eqs) | t1 == t2 = -- Note: equality check is fast + go acc eqs + go acc ((isTypVar -> Just x, t) : eqs) = + if x `occurs` t + then Left "Occurs check" + else go ((x, t) : map (second $ subst [(x, t)]) acc) + (map (subst [(x, t)] *** subst [(x, t)]) eqs) + go acc ((t, isTypVar -> Just x) : eqs) = + go acc ((mkTypVar x, t) : eqs) + go acc ((splitTyConApp -> (c1, ts1), splitTyConApp -> (c2, ts2)) : eqs) = + if c1 /= c2 + then Left $ "Cannot unify " ++ show c1 ++ " and " ++ show c2 + else go acc (zip ts1 ts2 ++ eqs) + +-------------------------------------------------------------------------------- +-- Pretty-printing -- +-------------------------------------------------------------------------------- + +instance Show TyCon where + showsPrec _ c = showString (tyConName c) + +instance Show TypeRep where + showsPrec p (splitTyConApp -> (tycon, tys)) = + case tys of + [] -> showsPrec p tycon + [anyIdx -> Just i] | tycon == typVar -> showString "ANY" . showIdx i + [x] | tycon == tcList -> + showChar '[' . shows x . showChar ']' + [a,r] | tycon == tcFun -> + showParen (p > 8) $ showsPrec 9 a + . showString " -> " + . showsPrec 8 r + xs | isTupleTyCon tycon -> + showTuple xs + _ -> + showParen (p > 9) $ showsPrec p tycon + . showChar ' ' + . showArgs tys + where + showIdx 0 = showString "" + showIdx i = shows i + +showArgs :: Show a => [a] -> ShowS +showArgs [] = id +showArgs [a] = showsPrec 10 a +showArgs (a:as) = showsPrec 10 a . showString " " . showArgs as + +anyIdx :: TypeRep -> Maybe Int +anyIdx (splitTyConApp -> (c, [])) | c == zeroTyCon = Just 0 +anyIdx (splitTyConApp -> (c, [t])) | c == succTyCon = (+1) <$> anyIdx t +anyIdx _ = Nothing + +showTuple :: [TypeRep] -> ShowS +showTuple args = showChar '(' + . foldr (.) id ( intersperse (showChar ',') + $ map (showsPrec 10) args + ) + . showChar ')' + +isTupleTyCon :: TyCon -> Bool +isTupleTyCon = isPrefixOf "(," . tyConName diff --git a/packages/rank1dynamic/tests/test.hs b/packages/rank1dynamic/tests/test.hs new file mode 100644 index 00000000..103494e4 --- /dev/null +++ b/packages/rank1dynamic/tests/test.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE CPP #-} +import Data.Rank1Dynamic +import Data.Rank1Typeable + +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test) +import Unsafe.Coerce + +funKindStr :: String +#if defined(MIN_VERSION_GLASGOW_HASKELL) && MIN_VERSION_GLASGOW_HASKELL(9,0,0,0) +funKindStr = "FUN" +#elif __GLASGOW_HASKELL__ >= 804 +funKindStr = "->" +#else +funKindStr = "(->)" +#endif + + +main :: IO () +main = defaultMain tests + +tests :: [Test] +tests = + [ testGroup "Examples of isInstanceOf" + [ testCase "CANNOT use a term of type 'Int -> Bool' as 'Int -> Int'" $ + typeOf (undefined :: Int -> Int) `isInstanceOf` typeOf (undefined :: Int -> Bool) + @?= Left "Cannot unify Int and Bool" + + , testCase "CAN use a term of type 'forall a. a -> Int' as 'Int -> Int'" $ + typeOf (undefined :: Int -> Int) `isInstanceOf` typeOf (undefined :: ANY -> Int) + @?= Right () + + , testCase "CAN use a term of type 'forall a b. a -> b' as 'forall a. a -> a'" $ + typeOf (undefined :: ANY -> ANY) `isInstanceOf` typeOf (undefined :: ANY -> ANY1) + @?= Right () + + , testCase "CANNOT use a term of type 'forall a. a -> a' as 'forall a b. a -> b'" $ + typeOf (undefined :: ANY -> ANY1) `isInstanceOf` typeOf (undefined :: ANY -> ANY) + @?= Left "Cannot unify Succ and Zero" + + , testCase "CAN use a term of type 'forall a. a' as 'forall a. a -> a'" $ + typeOf (undefined :: ANY -> ANY) `isInstanceOf` typeOf (undefined :: ANY) + @?= Right () + + , testCase "CANNOT use a term of type 'forall a. a -> a' as 'forall a. a'" $ + typeOf (undefined :: ANY) `isInstanceOf` typeOf (undefined :: ANY -> ANY) + @?= Left ("Cannot unify Skolem and " ++ funKindStr) + ] + + , testGroup "Examples of funResultTy" + [ testCase "Apply fn of type (forall a. a -> a) to arg of type Bool gives Bool" $ + show (funResultTy (typeOf (undefined :: ANY -> ANY)) (typeOf (undefined :: Bool))) + @?= "Right Bool" + + , testCase "Apply fn of type (forall a b. a -> b -> a) to arg of type Bool gives forall a. a -> Bool" $ + show (funResultTy (typeOf (undefined :: ANY -> ANY1 -> ANY)) (typeOf (undefined :: Bool))) + @?= "Right (ANY -> Bool)" -- forall a. a -> Bool + + , testCase "Apply fn of type (forall a. (Bool -> a) -> a) to argument of type (forall a. a -> a) gives Bool" $ + show (funResultTy (typeOf (undefined :: (Bool -> ANY) -> ANY)) (typeOf (undefined :: ANY -> ANY))) + @?= "Right Bool" + + , testCase "Apply fn of type (forall a b. a -> b -> a) to arg of type (forall a. a -> a) gives (forall a b. a -> b -> b)" $ + show (funResultTy (typeOf (undefined :: ANY -> ANY1 -> ANY)) (typeOf (undefined :: ANY1 -> ANY1))) + @?= "Right (ANY -> ANY1 -> ANY1)" + + , testCase "Cannot apply function of type (forall a. (a -> a) -> a -> a) to arg of type (Int -> Bool)" $ + show (funResultTy (typeOf (undefined :: (ANY -> ANY) -> (ANY -> ANY))) (typeOf (undefined :: Int -> Bool))) + @?= "Left \"Cannot unify Int and Bool\"" + ] + + , testGroup "Examples of fromDynamic" + [ testCase "CANNOT use a term of type 'Int -> Bool' as 'Int -> Int'" $ + do f <- fromDynamic (toDynamic (even :: Int -> Bool)) + return $ (f :: Int -> Int) 0 + @?= Left "Cannot unify Int and Bool" + + , testCase "CAN use a term of type 'forall a. a -> Int' as 'Int -> Int'" $ + do f <- fromDynamic (toDynamic (const 1 :: ANY -> Int)) + return $ (f :: Int -> Int) 0 + @?= Right 1 + + , testCase "CAN use a term of type 'forall a b. a -> b' as 'forall a. a -> a'" $ + do f <- fromDynamic (toDynamic (unsafeCoerce :: ANY1 -> ANY2)) + return $ (f :: Int -> Int) 0 + @?= Right 0 + + , testCase "CANNOT use a term of type 'forall a. a -> a' as 'forall a b. a -> b'" $ + do f <- fromDynamic (toDynamic (id :: ANY -> ANY)) + return $ (f :: Int -> Bool) 0 + @?= Left "Cannot unify Bool and Int" + + , testCase "CAN use a term of type 'forall a. a' as 'forall a. a -> a'" $ + case do f <- fromDynamic (toDynamic (undefined :: ANY)) + return $ (f :: Int -> Int) 0 + of + Right _ -> return () + result -> assertFailure $ "Expected 'Right _' but got '" ++ show result ++ "'" + + , testCase "CANNOT use a term of type 'forall a. a -> a' as 'forall a. a'" $ + do f <- fromDynamic (toDynamic (id :: ANY -> ANY)) ; return $ (f :: Int) + @?= Left ("Cannot unify Int and " ++ funKindStr) + ] + + , testGroup "Examples of dynApply" + [ testCase "Apply fn of type (forall a. a -> a) to arg of type Bool gives Bool" $ + do app <- toDynamic (id :: ANY -> ANY) `dynApply` toDynamic True + f <- fromDynamic app + return $ (f :: Bool) + @?= Right True + + , testCase "Apply fn of type (forall a b. a -> b -> a) to arg of type Bool gives forall a. a -> Bool" $ + do app <- toDynamic (const :: ANY -> ANY1 -> ANY) `dynApply` toDynamic True + f <- fromDynamic app + return $ (f :: Int -> Bool) 0 + @?= Right True + + , testCase "Apply fn of type (forall a. (Bool -> a) -> a) to argument of type (forall a. a -> a) gives Bool" $ + do app <- toDynamic (($ True) :: (Bool -> ANY) -> ANY) `dynApply` toDynamic (id :: ANY -> ANY) + f <- fromDynamic app + return (f :: Bool) + @?= Right True + + , testCase "Apply fn of type (forall a b. a -> b -> a) to arg of type (forall a. a -> a) gives (forall a b. a -> b -> b)" $ + do app <- toDynamic (const :: ANY -> ANY1 -> ANY) `dynApply` toDynamic (id :: ANY -> ANY) + f <- fromDynamic app ; return $ (f :: Int -> Bool -> Bool) 0 True + @?= Right True + + , testCase "Cannot apply function of type (forall a. (a -> a) -> a -> a) to arg of type (Int -> Bool)" $ + do app <- toDynamic ((\f -> f . f) :: (ANY -> ANY) -> ANY -> ANY) `dynApply` toDynamic (even :: Int -> Bool) ; f <- fromDynamic app ; return (f :: ()) + @?= Left "Cannot unify Int and Bool" + ] + ] diff --git a/stack-ghc-8.10.7.yaml b/stack-ghc-8.10.7.yaml index 2f33dd7a..a23ec9ca 100644 --- a/stack-ghc-8.10.7.yaml +++ b/stack-ghc-8.10.7.yaml @@ -1,16 +1,25 @@ resolver: lts-18.16 # Use GHC 8.10.7 packages: - - . - - distributed-process-tests/ + - packages/distributed-process + - packages/distributed-process-async + - packages/distributed-process-client-server + - packages/distributed-process-execution + - packages/distributed-process-extras + - packages/distributed-process-simplelocalnet + - packages/distributed-process-supervisor + - packages/distributed-process-systest + - packages/distributed-process-tests + - packages/distributed-static + - packages/network-transport + - packages/network-transport-inmemory + - packages/network-transport-tcp + - packages/network-transport-tests + - packages/rank1dynamic -extra-deps: -- distributed-static-0.3.9 -- network-transport-tcp-0.8.0 -# This version has its containers dependency bumped -- git: https://github.com/haskell-distributed/network-transport-inmemory.git - commit: 0ce97924f15a8c1570b2355151834305c9bd2a28 flags: distributed-process-tests: tcp: true +extra-deps: +- rematch-0.2.0.0@sha256:86019f4d6a4347e1291a0a9f85ba6324e1447e2b93d75958e59c24212e9d8178,1245 diff --git a/stack-ghc-9.0.2.yaml b/stack-ghc-9.0.2.yaml index b27dec34..3af58cf7 100644 --- a/stack-ghc-9.0.2.yaml +++ b/stack-ghc-9.0.2.yaml @@ -1,16 +1,25 @@ resolver: lts-19.28 # Use GHC 9.0.2 packages: - - . - - distributed-process-tests/ + - packages/distributed-process + - packages/distributed-process-async + - packages/distributed-process-client-server + - packages/distributed-process-execution + - packages/distributed-process-extras + - packages/distributed-process-simplelocalnet + - packages/distributed-process-supervisor + - packages/distributed-process-systest + - packages/distributed-process-tests + - packages/distributed-static + - packages/network-transport + - packages/network-transport-inmemory + - packages/network-transport-tcp + - packages/network-transport-tests + - packages/rank1dynamic -extra-deps: -- distributed-static-0.3.9 -- network-transport-tcp-0.8.0 -# This version has its containers dependency bumped -- git: https://github.com/haskell-distributed/network-transport-inmemory.git - commit: 0ce97924f15a8c1570b2355151834305c9bd2a28 flags: distributed-process-tests: tcp: true +extra-deps: +- rematch-0.2.0.0@sha256:86019f4d6a4347e1291a0a9f85ba6324e1447e2b93d75958e59c24212e9d8178,1245 diff --git a/stack-ghc-9.2.4.yaml b/stack-ghc-9.2.4.yaml deleted file mode 100644 index 7ce2f91f..00000000 --- a/stack-ghc-9.2.4.yaml +++ /dev/null @@ -1,20 +0,0 @@ -resolver: nightly-2022-10-11 -allow-newer: true - -packages: - - . - - distributed-process-tests/ - -extra-deps: -# Need to clone network-transport-tcp package and patch the file: -# src/Network/Transport/TCP/Internal.hs -# Change import of Data.ByteString.Lazy.Builder to Data.ByteString.Builder -- lib/network-transport-tcp -- distributed-static-0.3.9 -# This version has its containers dependency bumped -- git: https://github.com/haskell-distributed/network-transport-inmemory.git - commit: 0ce97924f15a8c1570b2355151834305c9bd2a28 - -flags: - distributed-process-tests: - tcp: true diff --git a/stack-ghc-9.2.7.yaml b/stack-ghc-9.2.7.yaml index 8c2d75a4..f48da6bf 100644 --- a/stack-ghc-9.2.7.yaml +++ b/stack-ghc-9.2.7.yaml @@ -1,18 +1,25 @@ resolver: lts-20.19 # Use GHC 9.2.7 packages: - - . - - distributed-process-tests/ + - packages/distributed-process + - packages/distributed-process-async + - packages/distributed-process-client-server + - packages/distributed-process-execution + - packages/distributed-process-extras + - packages/distributed-process-simplelocalnet + - packages/distributed-process-supervisor + - packages/distributed-process-systest + - packages/distributed-process-tests + - packages/distributed-static + - packages/network-transport + - packages/network-transport-inmemory + - packages/network-transport-tcp + - packages/network-transport-tests + - packages/rank1dynamic -extra-deps: -# Both distributed-static and network-transport-inmemory have -# revisions on hackage that bump dependencies like containers and -# bytestring. Explicit sha256 hashes seem to be needed to get the -# right revisions (4/30/23). -- distributed-static-0.3.9@sha256:f5e781867eddec660cb3b39805c849e3f096b7da245d43a07d8529e3c92b3a27 -- network-transport-inmemory-0.5.2@sha256:eead1fb207672127ccca1d04ae6a0eb20ee6ec10223eefb4274694dbbf4e9908 -- network-transport-tcp-0.8.1 flags: distributed-process-tests: tcp: true +extra-deps: +- rematch-0.2.0.0@sha256:86019f4d6a4347e1291a0a9f85ba6324e1447e2b93d75958e59c24212e9d8178,1245 diff --git a/stack-ghc-9.4.5.yaml b/stack-ghc-9.4.5.yaml index f9ed62d0..806cd43c 100644 --- a/stack-ghc-9.4.5.yaml +++ b/stack-ghc-9.4.5.yaml @@ -1,18 +1,25 @@ resolver: nightly-2023-05-01 # Use GHC 9.4.5 packages: - - . - - distributed-process-tests/ + - packages/distributed-process + - packages/distributed-process-async + - packages/distributed-process-client-server + - packages/distributed-process-execution + - packages/distributed-process-extras + - packages/distributed-process-simplelocalnet + - packages/distributed-process-supervisor + - packages/distributed-process-systest + - packages/distributed-process-tests + - packages/distributed-static + - packages/network-transport + - packages/network-transport-inmemory + - packages/network-transport-tcp + - packages/network-transport-tests + - packages/rank1dynamic -extra-deps: -# Both distributed-static and network-transport-inmemory have -# revisions on hackage that bump dependencies like containers and -# bytestring. Explicit sha256 hashes seem to be needed to get the -# right revisions (4/30/23). -- distributed-static-0.3.9@sha256:f5e781867eddec660cb3b39805c849e3f096b7da245d43a07d8529e3c92b3a27 -- network-transport-inmemory-0.5.2@sha256:eead1fb207672127ccca1d04ae6a0eb20ee6ec10223eefb4274694dbbf4e9908 -- network-transport-tcp-0.8.1 flags: distributed-process-tests: tcp: true +extra-deps: +- rematch-0.2.0.0@sha256:86019f4d6a4347e1291a0a9f85ba6324e1447e2b93d75958e59c24212e9d8178,1245 diff --git a/stack-ghc-9.8.2.yaml b/stack-ghc-9.8.2.yaml index 779d9815..227f6d12 100644 --- a/stack-ghc-9.8.2.yaml +++ b/stack-ghc-9.8.2.yaml @@ -1,15 +1,25 @@ resolver: nightly-2024-03-24 # Use GHC 9.8.2 packages: - - . - - distributed-process-tests/ + - packages/distributed-process + - packages/distributed-process-async + - packages/distributed-process-client-server + - packages/distributed-process-execution + - packages/distributed-process-extras + - packages/distributed-process-simplelocalnet + - packages/distributed-process-supervisor + - packages/distributed-process-systest + - packages/distributed-process-tests + - packages/distributed-static + - packages/network-transport + - packages/network-transport-inmemory + - packages/network-transport-tcp + - packages/network-transport-tests + - packages/rank1dynamic -extra-deps: -- distributed-static-0.3.10 -- network-transport-0.5.7 -- network-transport-tcp-0.8.2 -- network-transport-inmemory-0.5.3 flags: distributed-process-tests: tcp: true +extra-deps: +- rematch-0.2.0.0@sha256:86019f4d6a4347e1291a0a9f85ba6324e1447e2b93d75958e59c24212e9d8178,1245 diff --git a/website/.rvmrc b/website/.rvmrc new file mode 100644 index 00000000..35845a23 --- /dev/null +++ b/website/.rvmrc @@ -0,0 +1 @@ +rvm use 1.9.2 diff --git a/website/Gemfile b/website/Gemfile new file mode 100644 index 00000000..053c27dc --- /dev/null +++ b/website/Gemfile @@ -0,0 +1,2 @@ +source 'https://rubygems.org' +gem 'github-pages' diff --git a/website/Makefile b/website/Makefile new file mode 100644 index 00000000..c916692e --- /dev/null +++ b/website/Makefile @@ -0,0 +1,24 @@ + +NAME ?= '' +FNAME = $(shell echo $(NAME) | tr A-Z a-z) +ROOT_DIRECTORY=. +TEMPLATE_DIR=${ROOT_DIRECTORY}/static/templates +TEMPLATE_FILES=$(wildcard ${TEMPLATE_DIR}/*) +TEMPLATES=$(basename $(notdir ${TEMPLATE_FILES})) + +.PHONY: all +all: + $(info select a target) + $(info ${TEMPLATES}) + +ifneq ($(NAME), '') +$(TEMPLATES): + cat ${TEMPLATE_DIR}/$@.mdt | sed s/@PAGE@/${NAME}/g >> ${ROOT_DIRECTORY}/wiki/${FNAME}.md +else +$(TEMPLATES): + $(error you need to specify NAME= to run this target) +endif + +.PHONY: serve +serve: + jekyll serve -w diff --git a/website/_config.yml b/website/_config.yml new file mode 100644 index 00000000..943fdc2a --- /dev/null +++ b/website/_config.yml @@ -0,0 +1,16 @@ +exclude: [".rvmrc", ".rbenv-version", "README.md", "Rakefile", "static/templates/*"] +lsi: false +highlighter: pygments +safe: true +markdown: kramdown + +title: Cloud Haskell +tagline: Erlang-style concurrency for Haskell + +author: + name: Tim Watson + email: watson.timothy@gmail.com + github: hyperthunk + twitter: hyperthunk + +production_url: http://hyperthunk.github.com/website-next-preview diff --git a/website/_includes/footer.html b/website/_includes/footer.html new file mode 100644 index 00000000..ad4369cb --- /dev/null +++ b/website/_includes/footer.html @@ -0,0 +1,32 @@ + diff --git a/website/_includes/head.html b/website/_includes/head.html new file mode 100644 index 00000000..0319c679 --- /dev/null +++ b/website/_includes/head.html @@ -0,0 +1,29 @@ + + {{ page.title }} + + {% if page.description %}{% endif %} + + + + + + + + + + + + + + + + + + diff --git a/website/_includes/js.html b/website/_includes/js.html new file mode 100644 index 00000000..9461c48f --- /dev/null +++ b/website/_includes/js.html @@ -0,0 +1,3 @@ + + + diff --git a/website/_includes/nav.html b/website/_includes/nav.html new file mode 100644 index 00000000..4e45e258 --- /dev/null +++ b/website/_includes/nav.html @@ -0,0 +1,46 @@ +
+
+
+ + + + + + {{ site.title }} +
+ +
+
+
+
diff --git a/website/_layouts/default.html b/website/_layouts/default.html new file mode 100644 index 00000000..eeaa12ca --- /dev/null +++ b/website/_layouts/default.html @@ -0,0 +1,18 @@ + + + + {% include head.html %} + + + + {% include nav.html %} + {{ content }} + {% include footer.html %} + {% include js.html %} + + + diff --git a/website/_layouts/documentation.html b/website/_layouts/documentation.html new file mode 100644 index 00000000..6dbf5341 --- /dev/null +++ b/website/_layouts/documentation.html @@ -0,0 +1,42 @@ + + + + {% include head.html %} + + + + + {% include nav.html %} +
+ +
+
+
+
+ +
+
+ {{ content }} +
+
+
+ {% include footer.html %} + {% include js.html %} + + + diff --git a/website/_layouts/marketing.html b/website/_layouts/marketing.html new file mode 100644 index 00000000..6a22cf27 --- /dev/null +++ b/website/_layouts/marketing.html @@ -0,0 +1,55 @@ + + + + {% include head.html %} + + + + + + {% include nav.html %} + {{ content }} + {% include footer.html %} + {% include js.html %} + + + diff --git a/website/_layouts/page.html b/website/_layouts/page.html new file mode 100644 index 00000000..77126c5b --- /dev/null +++ b/website/_layouts/page.html @@ -0,0 +1,12 @@ +--- +layout: default +--- +
+
    +
  • Home /
    • +
  • {{ page.title }}
    • +
+
+
+ {{ content }} +
diff --git a/website/_layouts/post.html b/website/_layouts/post.html new file mode 100644 index 00000000..b187f732 --- /dev/null +++ b/website/_layouts/post.html @@ -0,0 +1,14 @@ +--- +layout: default +--- +
+
    +
  • Home /
    • +
  • Posts /
    • +
  • {{ page.date | date: "%B %d, %Y" }} /
    • +
  • {{ page.title }}
    • +
+
+
+ {{ content }} +
diff --git a/website/_layouts/site.html b/website/_layouts/site.html new file mode 100644 index 00000000..b6ce9ee3 --- /dev/null +++ b/website/_layouts/site.html @@ -0,0 +1,72 @@ +--- +title: Cloud Haskell +--- + + + + {% include head.html %} + + + + + {% include nav.html %} + + + +
+ {{ content }} +
+ + {% include footer.html %} + {% include js.html %} + + + + diff --git a/website/_layouts/team.html b/website/_layouts/team.html new file mode 100644 index 00000000..dd54a2d3 --- /dev/null +++ b/website/_layouts/team.html @@ -0,0 +1,39 @@ + + + + {% include head.html %} + + + + + {% include nav.html %} +
+ +
+
+
+
+ +
+
+ {{ content }} +
+
+
+ {% include footer.html %} + {% include js.html %} + + + diff --git a/website/_layouts/tutorial.html b/website/_layouts/tutorial.html new file mode 100644 index 00000000..a18a6268 --- /dev/null +++ b/website/_layouts/tutorial.html @@ -0,0 +1,41 @@ + + + + {% include head.html %} + + + + + {% include nav.html %} +
+ +
+
+
+
+
+
    + {% for section in page.sections %} +
  • + {{ section }} +
    • + {% endfor %} +
+
+
+
+ {{ content }} +
+
+
+ {% include footer.html %} + {% include js.html %} + + + diff --git a/website/_layouts/tutorial2.html b/website/_layouts/tutorial2.html new file mode 100644 index 00000000..575daf67 --- /dev/null +++ b/website/_layouts/tutorial2.html @@ -0,0 +1,40 @@ + + + + {% include head.html %} + + + + + {% include nav.html %} +
+ +
+
+
+
+ +
+
+ {{ content }} +
+
+
+ {% include footer.html %} + {% include js.html %} + + diff --git a/website/_layouts/wiki.html b/website/_layouts/wiki.html new file mode 100644 index 00000000..937ec08c --- /dev/null +++ b/website/_layouts/wiki.html @@ -0,0 +1,42 @@ + + + + {% include head.html %} + + + + + {% include nav.html %} +
+ +
+
+
+
+
+
    +
  • Wiki Home
    • + {% for page in site.pages %} + {% if page.url contains '/wiki/' %} +
  • {{ page.title }}
    • + {% endif %} + {% endfor %} +
+
+
+
+ {{ content }} +
+
+
+ {% include footer.html %} + {% include js.html %} + + + diff --git a/website/_posts/2012-01-21-cloud-haskell-appetiser.md b/website/_posts/2012-01-21-cloud-haskell-appetiser.md new file mode 100644 index 00000000..7beb402c --- /dev/null +++ b/website/_posts/2012-01-21-cloud-haskell-appetiser.md @@ -0,0 +1,9 @@ +--- +layout: post +category: well-typed +tags: [well-typed, blog, distributed-process] +title: "A Cloud Haskell Appetiser" +teaser: Hello Haskellers! We mentioned in the last digest that we'd have just a tiny bit more to say about Parallel Haskell.... +author: Eric Kow +link: http://www.well-typed.com/blog/68 +--- diff --git a/website/_posts/2012-10-04-the-new-cloud-haskell.md b/website/_posts/2012-10-04-the-new-cloud-haskell.md new file mode 100644 index 00000000..6b684582 --- /dev/null +++ b/website/_posts/2012-10-04-the-new-cloud-haskell.md @@ -0,0 +1,9 @@ +--- +layout: post +category: well-typed +tags: [well-typed, blog, distributed-process] +title: "The New Cloud Haskell" +teaser: For about the last year we have been working on a new implementation of Cloud Haskell... +author: Duncan Coutts +link: http://www.well-typed.com/blog/70 +--- diff --git a/website/_posts/2012-10-05-communication-patterns-in-cloud-haskell.md b/website/_posts/2012-10-05-communication-patterns-in-cloud-haskell.md new file mode 100644 index 00000000..1e300f22 --- /dev/null +++ b/website/_posts/2012-10-05-communication-patterns-in-cloud-haskell.md @@ -0,0 +1,9 @@ +--- +layout: post +category: well-typed +tags: [well-typed, blog, distributed-process] +title: "Communication Patterns in Cloud Haskell" +teaser: Master-Slave, Work-Stealing and Work-Pushing +author: Edsko de Vries +link: http://www.well-typed.com/blog/71 +--- diff --git a/website/_posts/2012-10-08-communication-patterns-in-cloud-haskell-2.md b/website/_posts/2012-10-08-communication-patterns-in-cloud-haskell-2.md new file mode 100644 index 00000000..bd711072 --- /dev/null +++ b/website/_posts/2012-10-08-communication-patterns-in-cloud-haskell-2.md @@ -0,0 +1,9 @@ +--- +layout: post +category: well-typed +tags: [well-typed, blog, distributed-process] +title: "Communication Patterns in Cloud Haskell (Part 2)" +teaser: Performance... +author: Edsko de Vries +link: http://www.well-typed.com/blog/72 +--- diff --git a/website/_posts/2012-10-12-communication-patterns-in-cloud-haskell-3.md b/website/_posts/2012-10-12-communication-patterns-in-cloud-haskell-3.md new file mode 100644 index 00000000..8ef10ca6 --- /dev/null +++ b/website/_posts/2012-10-12-communication-patterns-in-cloud-haskell-3.md @@ -0,0 +1,9 @@ +--- +layout: post +category: well-typed +tags: [well-typed, blog, distributed-process] +title: "Communication Patterns in Cloud Haskell (Part 3)" +teaser: Map-Reduce... +author: Edsko de Vries +link: http://www.well-typed.com/blog/73 +--- diff --git a/website/_posts/2012-10-15-communication-patterns-in-cloud-haskell-4.md b/website/_posts/2012-10-15-communication-patterns-in-cloud-haskell-4.md new file mode 100644 index 00000000..c863e6ce --- /dev/null +++ b/website/_posts/2012-10-15-communication-patterns-in-cloud-haskell-4.md @@ -0,0 +1,9 @@ +--- +layout: post +category: well-typed +tags: [well-typed, blog, distributed-process] +title: "Communication Patterns in Cloud Haskell (Part 4)" +teaser: K-Means... +author: Edsko de Vries +link: http://www.well-typed.com/blog/74 +--- diff --git a/website/_posts/2013-01-29-announce-0.4.2.md b/website/_posts/2013-01-29-announce-0.4.2.md new file mode 100644 index 00000000..7abd3490 --- /dev/null +++ b/website/_posts/2013-01-29-announce-0.4.2.md @@ -0,0 +1,9 @@ +--- +layout: post +category: announcements +tags: [announcement, distributed-process] +title: "[ANNOUNCE] distributed-process-0.4.2" +teaser: I am happy to announce the release of version 0.4.2 of the distributed-process package… +author: Tim Watson +link: http://groups.google.com/group/parallel-haskell/browse_thread/thread/15a2b0365059e59a/c5c8a373ab5a2f38?show_docid=c5c8a373ab5a2f38 +--- diff --git a/website/_posts/2013-02-07-problems-with-threaded.md b/website/_posts/2013-02-07-problems-with-threaded.md new file mode 100644 index 00000000..932f4749 --- /dev/null +++ b/website/_posts/2013-02-07-problems-with-threaded.md @@ -0,0 +1,9 @@ +--- +layout: post +category: well-typed +tags: [blog] +title: "Performance problems with -threaded?" +teaser: Performance problems with -threaded? +author: Edsko de Vries +link: http://www.edsko.net/2013/02/06/performance-problems-with-threaded/ +--- diff --git a/website/_posts/2014-02-06-new-cloud-haskell-website.md b/website/_posts/2014-02-06-new-cloud-haskell-website.md new file mode 100644 index 00000000..ddd44467 --- /dev/null +++ b/website/_posts/2014-02-06-new-cloud-haskell-website.md @@ -0,0 +1,9 @@ +--- +layout: post +category: announcements +tags: [announcement, distributed-process, website] +title: "[ANNOUNCE] New Cloud Haskell Website / Tutorials Preview" +teaser: Some updates to the website, documentation and tutorials are available for preview now +author: Tim Watson +link: https://groups.google.com/forum/#!topic/parallel-haskell/bApvWg7K7-4 +--- diff --git a/website/_posts/2014-02-12-static-pointers.md b/website/_posts/2014-02-12-static-pointers.md new file mode 100644 index 00000000..de339dd2 --- /dev/null +++ b/website/_posts/2014-02-12-static-pointers.md @@ -0,0 +1,9 @@ +--- +layout: post +category: announcements +tags: [announcement, distributed-process] +title: "[ANNOUNCE] Static Pointers Language Extension" +teaser: Simon reflects on Cloud-Haskell-style static pointers and serialisation +author: Simon PJ +link: https://ghc.haskell.org/trac/ghc/blog/simonpj/StaticPointers +--- diff --git a/website/_posts/2014-03-28-network-transport-zeromq.md b/website/_posts/2014-03-28-network-transport-zeromq.md new file mode 100644 index 00000000..8050ac7e --- /dev/null +++ b/website/_posts/2014-03-28-network-transport-zeromq.md @@ -0,0 +1,9 @@ +--- +layout: post +category: announcements +tags: [announcement, distributed-process] +title: "[ANNOUNCE] network-transport-zeromq-0.1" +teaser: I'm happy to announce a new network-transport backend based on the 0MQ brokerless protocol +author: Alexander Vershilov +link: https://groups.google.com/forum/#!topic/parallel-haskell/1Yu1VkI7YkY +--- diff --git a/website/_posts/2014-05-30-cloud-haskell-release-candidate-on-hackage.md b/website/_posts/2014-05-30-cloud-haskell-release-candidate-on-hackage.md new file mode 100644 index 00000000..a5cc8887 --- /dev/null +++ b/website/_posts/2014-05-30-cloud-haskell-release-candidate-on-hackage.md @@ -0,0 +1,9 @@ +--- +layout: post +category: announcements +tags: [announcement, distributed-process] +title: "[ANNOUNCE] Cloud Haskell Release Candidate on Hackage" +teaser: The latest version of Cloud Haskell is finally being released onto hackage. +author: Tim Watson +link: https://groups.google.com/forum/#!topic/parallel-haskell/1Yu1VkI7YkY +--- diff --git a/website/_posts/2014-06-13-cloud-haskell-is-live.md b/website/_posts/2014-06-13-cloud-haskell-is-live.md new file mode 100644 index 00000000..1f2bff29 --- /dev/null +++ b/website/_posts/2014-06-13-cloud-haskell-is-live.md @@ -0,0 +1,9 @@ +--- +layout: post +category: announcements +tags: [announcement, distributed-process] +title: "[ANNOUNCE] Cloud Haskell is Live!" +teaser: The latest version of Cloud Haskell is finally being released onto hackage. +author: Tim Watson +link: https://groups.google.com/forum/#!topic/parallel-haskell/1Yu1VkI7YkY +--- diff --git a/website/_posts/2014-08-13-distributed-process-0.5.1.md b/website/_posts/2014-08-13-distributed-process-0.5.1.md new file mode 100644 index 00000000..2e3ab4df --- /dev/null +++ b/website/_posts/2014-08-13-distributed-process-0.5.1.md @@ -0,0 +1,9 @@ +--- +layout: post +category: announcements +tags: [announcement, distributed-process] +title: "[ANNOUNCE] distributed-process-0.5.1" +teaser: A bug-fix version of distributed-process has been uploaded to hackage. +author: Tim Watson +link: https://groups.google.com/forum/#!topic/parallel-haskell/kRksoYRLGes +--- diff --git a/website/_posts/2015-06-17-cloud-haskell-0.2.2.md b/website/_posts/2015-06-17-cloud-haskell-0.2.2.md new file mode 100644 index 00000000..60463ff9 --- /dev/null +++ b/website/_posts/2015-06-17-cloud-haskell-0.2.2.md @@ -0,0 +1,9 @@ +--- +layout: post +category: announcements +tags: [announcement, distributed-process] +title: "[ANNOUNCE] Cloud Haskell 0.2.2" +teaser: A bug-fix version of Cloud Haskell stack has been uploaded to hackage. +author: Facundo Domínguez +link: https://groups.google.com/forum/#!topic/distributed-haskell/bOZ-ey43myE +--- diff --git a/website/_posts/2015-06-30-network-transport-inmemory-0.5.0.md b/website/_posts/2015-06-30-network-transport-inmemory-0.5.0.md new file mode 100644 index 00000000..2fae3074 --- /dev/null +++ b/website/_posts/2015-06-30-network-transport-inmemory-0.5.0.md @@ -0,0 +1,9 @@ +--- +layout: post +category: announcements +tags: [announcement, network-transport-inmemory] +title: "[ANNOUNCE] network-transport-inmemory 0.5.0" +teaser: The first release of network-transport-inmemory has been uploaded to hackage. +author: Facundo Domínguez +link: https://groups.google.com/forum/#!topic/distributed-haskell/gD8XP0wDuvU +--- diff --git a/website/_posts/2016-02-19-announce-0.6.0.md b/website/_posts/2016-02-19-announce-0.6.0.md new file mode 100644 index 00000000..c4d75b46 --- /dev/null +++ b/website/_posts/2016-02-19-announce-0.6.0.md @@ -0,0 +1,9 @@ +--- +layout: post +category: announcements +tags: [announcement, distributed-process] +title: "[ANNOUNCE] distributed-process-0.6.0" +teaser: A new version of Cloud Haskell stack has been uploaded to hackage. +author: Facundo Domínguez +link: https://groups.google.com/forum/#!topic/distributed-haskell/A_LuR_XXZdE +--- diff --git a/website/about.html b/website/about.html new file mode 100644 index 00000000..5a13f069 --- /dev/null +++ b/website/about.html @@ -0,0 +1,16 @@ +--- +layout: page +title: About +--- + +Cloud Haskell is cool + +
+

Install Cloud Haskell

+

You can retrieve the latest version of Cloud Haskell from github.

+

+ + View on Github + +

+
diff --git a/website/changes.md b/website/changes.md new file mode 100644 index 00000000..178c6151 --- /dev/null +++ b/website/changes.md @@ -0,0 +1,31 @@ +--- +layout: changes +title: Changelog +--- + +### Viewing Changes + +Each version of each cloud haskell project has a change log, which can be +viewed by clicking on the links to the left hand side of this page. + +### Editing + +Editing this page is pretty simple. This entire website is stored in a git +repository and its dynamic content rendered by github pages using [Jekyll][1]. +You can clone the repository [here][2]. Instructions for using jekyll are +available [online][1], but in general it's just a matter of finding the right +markdown file. Wiki content is all located in the wiki subfolder. + +### Adding new content + +We plan to set up a script that pulls the Jira RSS feed and inserts content +here, however for the time being, adding a new page beneath the `changelog` +folder will be sufficient to pull a new version into the navigation menu. +Our Jira instance is set up to produce HTML release notes which can be tweaked +by hand if necessary and the front matter for change-logs can be copied from +one of the existing pages. + + +[1]: https://github.com/mojombo/jekyll +[2]: https://github.com/haskell-distributed/haskell-distributed.github.com +[3]: https://github.com/mojombo/jekyll/wiki/YAML-Front-Matter diff --git a/website/contact.html b/website/contact.html new file mode 100644 index 00000000..5adf6c86 --- /dev/null +++ b/website/contact.html @@ -0,0 +1,43 @@ +--- +layout: marketing +title: Contact +--- + +
+
    +
  • Home /
    • +
  • Contact
    • +
+
+ +
+
+
+ +
+
+ +
+
+ +
+
+ +
+
+

Slack

+

People have been active on Slack recently. Get an invite and drop in.

+

Get a Slack invite

+
+
+

IRC

+

You'll probably find us lurking in the #haskell-distributed channel on freenode, where you can get help with your questions. There is also the general purpose #haskell channel.

+

Visit us on IRC

+
+
+

Email

+

If you have any questions or concerns, please email the parallel-haskell mailing list in the first instace.

+

Send Email

+
+
+
diff --git a/website/css/bootstrap-responsive.css b/website/css/bootstrap-responsive.css new file mode 100644 index 00000000..a3352d77 --- /dev/null +++ b/website/css/bootstrap-responsive.css @@ -0,0 +1,1092 @@ +/*! + * Bootstrap Responsive v2.2.2 + * + * Copyright 2012 Twitter, Inc + * Licensed under the Apache License v2.0 + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Designed and built with all the love in the world @twitter by @mdo and @fat. + */ + +@-ms-viewport { + width: device-width; +} + +.clearfix { + *zoom: 1; +} + +.clearfix:before, +.clearfix:after { + display: table; + line-height: 0; + content: ""; +} + +.clearfix:after { + clear: both; +} + +.hide-text { + font: 0/0 a; + color: transparent; + text-shadow: none; + background-color: transparent; + border: 0; +} + +.input-block-level { + display: block; + width: 100%; + min-height: 30px; + -webkit-box-sizing: border-box; + -moz-box-sizing: border-box; + box-sizing: border-box; +} + +.hidden { + display: none; + visibility: hidden; +} + +.visible-phone { + display: none !important; +} + +.visible-tablet { + display: none !important; +} + +.hidden-desktop { + display: none !important; +} + +.visible-desktop { + display: inherit !important; +} + +@media (min-width: 768px) and (max-width: 979px) { + .hidden-desktop { + display: inherit !important; + } + .visible-desktop { + display: none !important ; + } + .visible-tablet { + display: inherit !important; + } + .hidden-tablet { + display: none !important; + } +} + +@media (max-width: 767px) { + .hidden-desktop { + display: inherit !important; + } + .visible-desktop { + display: none !important; + } + .visible-phone { + display: inherit !important; + } + .hidden-phone { + display: none !important; + } +} + +@media (min-width: 1200px) { + .row { + margin-left: -30px; + *zoom: 1; + } + .row:before, + .row:after { + display: table; + line-height: 0; + content: ""; + } + .row:after { + clear: both; + } + [class*="span"] { + float: left; + min-height: 1px; + margin-left: 30px; + } + .container, + .navbar-static-top .container, + .navbar-fixed-top .container, + .navbar-fixed-bottom .container { + width: 1170px; + } + .span12 { + width: 1170px; + } + .span11 { + width: 1070px; + } + .span10 { + width: 970px; + } + .span9 { + width: 870px; + } + .span8 { + width: 770px; + } + .span7 { + width: 670px; + } + .span6 { + width: 570px; + } + .span5 { + width: 470px; + } + .span4 { + width: 370px; + } + .span3 { + width: 270px; + } + .span2 { + width: 170px; + } + .span1 { + width: 70px; + } + .offset12 { + margin-left: 1230px; + } + .offset11 { + margin-left: 1130px; + } + .offset10 { + margin-left: 1030px; + } + .offset9 { + margin-left: 930px; + } + .offset8 { + margin-left: 830px; + } + .offset7 { + margin-left: 730px; + } + .offset6 { + margin-left: 630px; + } + .offset5 { + margin-left: 530px; + } + .offset4 { + margin-left: 430px; + } + .offset3 { + margin-left: 330px; + } + .offset2 { + margin-left: 230px; + } + .offset1 { + margin-left: 130px; + } + .row-fluid { + width: 100%; + *zoom: 1; + } + .row-fluid:before, + .row-fluid:after { + display: table; + line-height: 0; + content: ""; + } + .row-fluid:after { + clear: both; + } + .row-fluid [class*="span"] { + display: block; + float: left; + width: 100%; + min-height: 30px; + margin-left: 2.564102564102564%; + *margin-left: 2.5109110747408616%; + -webkit-box-sizing: border-box; + -moz-box-sizing: border-box; + box-sizing: border-box; + } + .row-fluid [class*="span"]:first-child { + margin-left: 0; + } + .row-fluid .controls-row [class*="span"] + [class*="span"] { + margin-left: 2.564102564102564%; + } + .row-fluid .span12 { + width: 100%; + *width: 99.94680851063829%; + } + .row-fluid .span11 { + width: 91.45299145299145%; + *width: 91.39979996362975%; + } + .row-fluid .span10 { + width: 82.90598290598291%; + *width: 82.8527914166212%; + } + .row-fluid .span9 { + width: 74.35897435897436%; + *width: 74.30578286961266%; + } + .row-fluid .span8 { + width: 65.81196581196582%; + *width: 65.75877432260411%; + } + .row-fluid .span7 { + width: 57.26495726495726%; + *width: 57.21176577559556%; + } + .row-fluid .span6 { + width: 48.717948717948715%; + *width: 48.664757228587014%; + } + .row-fluid .span5 { + width: 40.17094017094017%; + *width: 40.11774868157847%; + } + .row-fluid .span4 { + width: 31.623931623931625%; + *width: 31.570740134569924%; + } + .row-fluid .span3 { + width: 23.076923076923077%; + *width: 23.023731587561375%; + } + .row-fluid .span2 { + width: 14.52991452991453%; + *width: 14.476723040552828%; + } + .row-fluid .span1 { + width: 5.982905982905983%; + *width: 5.929714493544281%; + } + .row-fluid .offset12 { + margin-left: 105.12820512820512%; + *margin-left: 105.02182214948171%; + } + .row-fluid .offset12:first-child { + margin-left: 102.56410256410257%; + *margin-left: 102.45771958537915%; + } + .row-fluid .offset11 { + margin-left: 96.58119658119658%; + *margin-left: 96.47481360247316%; + } + .row-fluid .offset11:first-child { + margin-left: 94.01709401709402%; + *margin-left: 93.91071103837061%; + } + .row-fluid .offset10 { + margin-left: 88.03418803418803%; + *margin-left: 87.92780505546462%; + } + .row-fluid .offset10:first-child { + margin-left: 85.47008547008548%; + *margin-left: 85.36370249136206%; + } + .row-fluid .offset9 { + margin-left: 79.48717948717949%; + *margin-left: 79.38079650845607%; + } + .row-fluid .offset9:first-child { + margin-left: 76.92307692307693%; + *margin-left: 76.81669394435352%; + } + .row-fluid .offset8 { + margin-left: 70.94017094017094%; + *margin-left: 70.83378796144753%; + } + .row-fluid .offset8:first-child { + margin-left: 68.37606837606839%; + *margin-left: 68.26968539734497%; + } + .row-fluid .offset7 { + margin-left: 62.393162393162385%; + *margin-left: 62.28677941443899%; + } + .row-fluid .offset7:first-child { + margin-left: 59.82905982905982%; + *margin-left: 59.72267685033642%; + } + .row-fluid .offset6 { + margin-left: 53.84615384615384%; + *margin-left: 53.739770867430444%; + } + .row-fluid .offset6:first-child { + margin-left: 51.28205128205128%; + *margin-left: 51.175668303327875%; + } + .row-fluid .offset5 { + margin-left: 45.299145299145295%; + *margin-left: 45.1927623204219%; + } + .row-fluid .offset5:first-child { + margin-left: 42.73504273504273%; + *margin-left: 42.62865975631933%; + } + .row-fluid .offset4 { + margin-left: 36.75213675213675%; + *margin-left: 36.645753773413354%; + } + .row-fluid .offset4:first-child { + margin-left: 34.18803418803419%; + *margin-left: 34.081651209310785%; + } + .row-fluid .offset3 { + margin-left: 28.205128205128204%; + *margin-left: 28.0987452264048%; + } + .row-fluid .offset3:first-child { + margin-left: 25.641025641025642%; + *margin-left: 25.53464266230224%; + } + .row-fluid .offset2 { + margin-left: 19.65811965811966%; + *margin-left: 19.551736679396257%; + } + .row-fluid .offset2:first-child { + margin-left: 17.094017094017094%; + *margin-left: 16.98763411529369%; + } + .row-fluid .offset1 { + margin-left: 11.11111111111111%; + *margin-left: 11.004728132387708%; + } + .row-fluid .offset1:first-child { + margin-left: 8.547008547008547%; + *margin-left: 8.440625568285142%; + } + input, + textarea, + .uneditable-input { + margin-left: 0; + } + .controls-row [class*="span"] + [class*="span"] { + margin-left: 30px; + } + input.span12, + textarea.span12, + .uneditable-input.span12 { + width: 1156px; + } + input.span11, + textarea.span11, + .uneditable-input.span11 { + width: 1056px; + } + input.span10, + textarea.span10, + .uneditable-input.span10 { + width: 956px; + } + input.span9, + textarea.span9, + .uneditable-input.span9 { + width: 856px; + } + input.span8, + textarea.span8, + .uneditable-input.span8 { + width: 756px; + } + input.span7, + textarea.span7, + .uneditable-input.span7 { + width: 656px; + } + input.span6, + textarea.span6, + .uneditable-input.span6 { + width: 556px; + } + input.span5, + textarea.span5, + .uneditable-input.span5 { + width: 456px; + } + input.span4, + textarea.span4, + .uneditable-input.span4 { + width: 356px; + } + input.span3, + textarea.span3, + .uneditable-input.span3 { + width: 256px; + } + input.span2, + textarea.span2, + .uneditable-input.span2 { + width: 156px; + } + input.span1, + textarea.span1, + .uneditable-input.span1 { + width: 56px; + } + .thumbnails { + margin-left: -30px; + } + .thumbnails > li { + margin-left: 30px; + } + .row-fluid .thumbnails { + margin-left: 0; + } +} + +@media (min-width: 768px) and (max-width: 979px) { + .row { + margin-left: -20px; + *zoom: 1; + } + .row:before, + .row:after { + display: table; + line-height: 0; + content: ""; + } + .row:after { + clear: both; + } + [class*="span"] { + float: left; + min-height: 1px; + margin-left: 20px; + } + .container, + .navbar-static-top .container, + .navbar-fixed-top .container, + .navbar-fixed-bottom .container { + width: 724px; + } + .span12 { + width: 724px; + } + .span11 { + width: 662px; + } + .span10 { + width: 600px; + } + .span9 { + width: 538px; + } + .span8 { + width: 476px; + } + .span7 { + width: 414px; + } + .span6 { + width: 352px; + } + .span5 { + width: 290px; + } + .span4 { + width: 228px; + } + .span3 { + width: 166px; + } + .span2 { + width: 104px; + } + .span1 { + width: 42px; + } + .offset12 { + margin-left: 764px; + } + .offset11 { + margin-left: 702px; + } + .offset10 { + margin-left: 640px; + } + .offset9 { + margin-left: 578px; + } + .offset8 { + margin-left: 516px; + } + .offset7 { + margin-left: 454px; + } + .offset6 { + margin-left: 392px; + } + .offset5 { + margin-left: 330px; + } + .offset4 { + margin-left: 268px; + } + .offset3 { + margin-left: 206px; + } + .offset2 { + margin-left: 144px; + } + .offset1 { + margin-left: 82px; + } + .row-fluid { + width: 100%; + *zoom: 1; + } + .row-fluid:before, + .row-fluid:after { + display: table; + line-height: 0; + content: ""; + } + .row-fluid:after { + clear: both; + } + .row-fluid [class*="span"] { + display: block; + float: left; + width: 100%; + min-height: 30px; + margin-left: 2.7624309392265194%; + *margin-left: 2.709239449864817%; + -webkit-box-sizing: border-box; + -moz-box-sizing: border-box; + box-sizing: border-box; + } + .row-fluid [class*="span"]:first-child { + margin-left: 0; + } + .row-fluid .controls-row [class*="span"] + [class*="span"] { + margin-left: 2.7624309392265194%; + } + .row-fluid .span12 { + width: 100%; + *width: 99.94680851063829%; + } + .row-fluid .span11 { + width: 91.43646408839778%; + *width: 91.38327259903608%; + } + .row-fluid .span10 { + width: 82.87292817679558%; + *width: 82.81973668743387%; + } + .row-fluid .span9 { + width: 74.30939226519337%; + *width: 74.25620077583166%; + } + .row-fluid .span8 { + width: 65.74585635359117%; + *width: 65.69266486422946%; + } + .row-fluid .span7 { + width: 57.18232044198895%; + *width: 57.12912895262725%; + } + .row-fluid .span6 { + width: 48.61878453038674%; + *width: 48.56559304102504%; + } + .row-fluid .span5 { + width: 40.05524861878453%; + *width: 40.00205712942283%; + } + .row-fluid .span4 { + width: 31.491712707182323%; + *width: 31.43852121782062%; + } + .row-fluid .span3 { + width: 22.92817679558011%; + *width: 22.87498530621841%; + } + .row-fluid .span2 { + width: 14.3646408839779%; + *width: 14.311449394616199%; + } + .row-fluid .span1 { + width: 5.801104972375691%; + *width: 5.747913483013988%; + } + .row-fluid .offset12 { + margin-left: 105.52486187845304%; + *margin-left: 105.41847889972962%; + } + .row-fluid .offset12:first-child { + margin-left: 102.76243093922652%; + *margin-left: 102.6560479605031%; + } + .row-fluid .offset11 { + margin-left: 96.96132596685082%; + *margin-left: 96.8549429881274%; + } + .row-fluid .offset11:first-child { + margin-left: 94.1988950276243%; + *margin-left: 94.09251204890089%; + } + .row-fluid .offset10 { + margin-left: 88.39779005524862%; + *margin-left: 88.2914070765252%; + } + .row-fluid .offset10:first-child { + margin-left: 85.6353591160221%; + *margin-left: 85.52897613729868%; + } + .row-fluid .offset9 { + margin-left: 79.8342541436464%; + *margin-left: 79.72787116492299%; + } + .row-fluid .offset9:first-child { + margin-left: 77.07182320441989%; + *margin-left: 76.96544022569647%; + } + .row-fluid .offset8 { + margin-left: 71.2707182320442%; + *margin-left: 71.16433525332079%; + } + .row-fluid .offset8:first-child { + margin-left: 68.50828729281768%; + *margin-left: 68.40190431409427%; + } + .row-fluid .offset7 { + margin-left: 62.70718232044199%; + *margin-left: 62.600799341718584%; + } + .row-fluid .offset7:first-child { + margin-left: 59.94475138121547%; + *margin-left: 59.838368402492065%; + } + .row-fluid .offset6 { + margin-left: 54.14364640883978%; + *margin-left: 54.037263430116376%; + } + .row-fluid .offset6:first-child { + margin-left: 51.38121546961326%; + *margin-left: 51.27483249088986%; + } + .row-fluid .offset5 { + margin-left: 45.58011049723757%; + *margin-left: 45.47372751851417%; + } + .row-fluid .offset5:first-child { + margin-left: 42.81767955801105%; + *margin-left: 42.71129657928765%; + } + .row-fluid .offset4 { + margin-left: 37.01657458563536%; + *margin-left: 36.91019160691196%; + } + .row-fluid .offset4:first-child { + margin-left: 34.25414364640884%; + *margin-left: 34.14776066768544%; + } + .row-fluid .offset3 { + margin-left: 28.45303867403315%; + *margin-left: 28.346655695309746%; + } + .row-fluid .offset3:first-child { + margin-left: 25.69060773480663%; + *margin-left: 25.584224756083227%; + } + .row-fluid .offset2 { + margin-left: 19.88950276243094%; + *margin-left: 19.783119783707537%; + } + .row-fluid .offset2:first-child { + margin-left: 17.12707182320442%; + *margin-left: 17.02068884448102%; + } + .row-fluid .offset1 { + margin-left: 11.32596685082873%; + *margin-left: 11.219583872105325%; + } + .row-fluid .offset1:first-child { + margin-left: 8.56353591160221%; + *margin-left: 8.457152932878806%; + } + input, + textarea, + .uneditable-input { + margin-left: 0; + } + .controls-row [class*="span"] + [class*="span"] { + margin-left: 20px; + } + input.span12, + textarea.span12, + .uneditable-input.span12 { + width: 710px; + } + input.span11, + textarea.span11, + .uneditable-input.span11 { + width: 648px; + } + input.span10, + textarea.span10, + .uneditable-input.span10 { + width: 586px; + } + input.span9, + textarea.span9, + .uneditable-input.span9 { + width: 524px; + } + input.span8, + textarea.span8, + .uneditable-input.span8 { + width: 462px; + } + input.span7, + textarea.span7, + .uneditable-input.span7 { + width: 400px; + } + input.span6, + textarea.span6, + .uneditable-input.span6 { + width: 338px; + } + input.span5, + textarea.span5, + .uneditable-input.span5 { + width: 276px; + } + input.span4, + textarea.span4, + .uneditable-input.span4 { + width: 214px; + } + input.span3, + textarea.span3, + .uneditable-input.span3 { + width: 152px; + } + input.span2, + textarea.span2, + .uneditable-input.span2 { + width: 90px; + } + input.span1, + textarea.span1, + .uneditable-input.span1 { + width: 28px; + } +} + +@media (max-width: 767px) { + body { + padding-right: 20px; + padding-left: 20px; + } + .navbar-fixed-top, + .navbar-fixed-bottom, + .navbar-static-top { + margin-right: -20px; + margin-left: -20px; + } + .container-fluid { + padding: 0; + } + .dl-horizontal dt { + float: none; + width: auto; + clear: none; + text-align: left; + } + .dl-horizontal dd { + margin-left: 0; + } + .container { + width: auto; + } + .row-fluid { + width: 100%; + } + .row, + .thumbnails { + margin-left: 0; + } + .thumbnails > li { + float: none; + margin-left: 0; + } + [class*="span"], + .uneditable-input[class*="span"], + .row-fluid [class*="span"] { + display: block; + float: none; + width: 100%; + margin-left: 0; + -webkit-box-sizing: border-box; + -moz-box-sizing: border-box; + box-sizing: border-box; + } + .span12, + .row-fluid .span12 { + width: 100%; + -webkit-box-sizing: border-box; + -moz-box-sizing: border-box; + box-sizing: border-box; + } + .row-fluid [class*="offset"]:first-child { + margin-left: 0; + } + .input-large, + .input-xlarge, + .input-xxlarge, + input[class*="span"], + select[class*="span"], + textarea[class*="span"], + .uneditable-input { + display: block; + width: 100%; + min-height: 30px; + -webkit-box-sizing: border-box; + -moz-box-sizing: border-box; + box-sizing: border-box; + } + .input-prepend input, + .input-append input, + .input-prepend input[class*="span"], + .input-append input[class*="span"] { + display: inline-block; + width: auto; + } + .controls-row [class*="span"] + [class*="span"] { + margin-left: 0; + } + .modal { + position: fixed; + top: 20px; + right: 20px; + left: 20px; + width: auto; + margin: 0; + } + .modal.fade { + top: -100px; + } + .modal.fade.in { + top: 20px; + } +} + +@media (max-width: 480px) { + .nav-collapse { + -webkit-transform: translate3d(0, 0, 0); + } + .page-header h1 small { + display: block; + line-height: 20px; + } + input[type="checkbox"], + input[type="radio"] { + border: 1px solid #ccc; + } + .form-horizontal .control-label { + float: none; + width: auto; + padding-top: 0; + text-align: left; + } + .form-horizontal .controls { + margin-left: 0; + } + .form-horizontal .control-list { + padding-top: 0; + } + .form-horizontal .form-actions { + padding-right: 10px; + padding-left: 10px; + } + .media .pull-left, + .media .pull-right { + display: block; + float: none; + margin-bottom: 10px; + } + .media-object { + margin-right: 0; + margin-left: 0; + } + .modal { + top: 10px; + right: 10px; + left: 10px; + } + .modal-header .close { + padding: 10px; + margin: -10px; + } + .carousel-caption { + position: static; + } +} + +@media (max-width: 979px) { + body { + padding-top: 0; + } + .navbar-fixed-top, + .navbar-fixed-bottom { + position: static; + } + .navbar-fixed-top { + margin-bottom: 20px; + } + .navbar-fixed-bottom { + margin-top: 20px; + } + .navbar-fixed-top .navbar-inner, + .navbar-fixed-bottom .navbar-inner { + padding: 5px; + } + .navbar .container { + width: auto; + padding: 0; + } + .navbar .brand { + padding-right: 10px; + padding-left: 10px; + margin: 0 0 0 -5px; + } + .nav-collapse { + clear: both; + } + .nav-collapse .nav { + float: none; + margin: 0 0 10px; + } + .nav-collapse .nav > li { + float: none; + } + .nav-collapse .nav > li > a { + margin-bottom: 2px; + } + .nav-collapse .nav > .divider-vertical { + display: none; + } + .nav-collapse .nav .nav-header { + color: #777777; + text-shadow: none; + } + .nav-collapse .nav > li > a, + .nav-collapse .dropdown-menu a { + padding: 9px 15px; + font-weight: bold; + color: #777777; + -webkit-border-radius: 3px; + -moz-border-radius: 3px; + border-radius: 3px; + } + .nav-collapse .btn { + padding: 4px 10px 4px; + font-weight: normal; + -webkit-border-radius: 4px; + -moz-border-radius: 4px; + border-radius: 4px; + } + .nav-collapse .dropdown-menu li + li a { + margin-bottom: 2px; + } + .nav-collapse .nav > li > a:hover, + .nav-collapse .dropdown-menu a:hover { + background-color: #f2f2f2; + } + .navbar-inverse .nav-collapse .nav > li > a, + .navbar-inverse .nav-collapse .dropdown-menu a { + color: #999999; + } + .navbar-inverse .nav-collapse .nav > li > a:hover, + .navbar-inverse .nav-collapse .dropdown-menu a:hover { + background-color: #111111; + } + .nav-collapse.in .btn-group { + padding: 0; + margin-top: 5px; + } + .nav-collapse .dropdown-menu { + position: static; + top: auto; + left: auto; + display: none; + float: none; + max-width: none; + padding: 0; + margin: 0 15px; + background-color: transparent; + border: none; + -webkit-border-radius: 0; + -moz-border-radius: 0; + border-radius: 0; + -webkit-box-shadow: none; + -moz-box-shadow: none; + box-shadow: none; + } + .nav-collapse .open > .dropdown-menu { + display: block; + } + .nav-collapse .dropdown-menu:before, + .nav-collapse .dropdown-menu:after { + display: none; + } + .nav-collapse .dropdown-menu .divider { + display: none; + } + .nav-collapse .nav > li > .dropdown-menu:before, + .nav-collapse .nav > li > .dropdown-menu:after { + display: none; + } + .nav-collapse .navbar-form, + .nav-collapse .navbar-search { + float: none; + padding: 10px 15px; + margin: 10px 0; + border-top: 1px solid #f2f2f2; + border-bottom: 1px solid #f2f2f2; + -webkit-box-shadow: inset 0 1px 0 rgba(255, 255, 255, 0.1), 0 1px 0 rgba(255, 255, 255, 0.1); + -moz-box-shadow: inset 0 1px 0 rgba(255, 255, 255, 0.1), 0 1px 0 rgba(255, 255, 255, 0.1); + box-shadow: inset 0 1px 0 rgba(255, 255, 255, 0.1), 0 1px 0 rgba(255, 255, 255, 0.1); + } + .navbar-inverse .nav-collapse .navbar-form, + .navbar-inverse .nav-collapse .navbar-search { + border-top-color: #111111; + border-bottom-color: #111111; + } + .navbar .nav-collapse .nav.pull-right { + float: none; + margin-left: 0; + } + .nav-collapse, + .nav-collapse.collapse { + height: 0; + overflow: hidden; + } + .navbar .btn-navbar { + display: block; + } + .navbar-static .navbar-inner { + padding-right: 10px; + padding-left: 10px; + } +} + +@media (min-width: 980px) { + .nav-collapse.collapse { + height: auto !important; + overflow: visible !important; + } +} diff --git a/website/css/bootstrap-responsive.min.css b/website/css/bootstrap-responsive.min.css new file mode 100644 index 00000000..5cb833ff --- /dev/null +++ b/website/css/bootstrap-responsive.min.css @@ -0,0 +1,9 @@ +/*! + * Bootstrap Responsive v2.2.2 + * + * Copyright 2012 Twitter, Inc + * Licensed under the Apache License v2.0 + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Designed and built with all the love in the world @twitter by @mdo and @fat. + */@-ms-viewport{width:device-width}.clearfix{*zoom:1}.clearfix:before,.clearfix:after{display:table;line-height:0;content:""}.clearfix:after{clear:both}.hide-text{font:0/0 a;color:transparent;text-shadow:none;background-color:transparent;border:0}.input-block-level{display:block;width:100%;min-height:30px;-webkit-box-sizing:border-box;-moz-box-sizing:border-box;box-sizing:border-box}.hidden{display:none;visibility:hidden}.visible-phone{display:none!important}.visible-tablet{display:none!important}.hidden-desktop{display:none!important}.visible-desktop{display:inherit!important}@media(min-width:768px) and (max-width:979px){.hidden-desktop{display:inherit!important}.visible-desktop{display:none!important}.visible-tablet{display:inherit!important}.hidden-tablet{display:none!important}}@media(max-width:767px){.hidden-desktop{display:inherit!important}.visible-desktop{display:none!important}.visible-phone{display:inherit!important}.hidden-phone{display:none!important}}@media(min-width:1200px){.row{margin-left:-30px;*zoom:1}.row:before,.row:after{display:table;line-height:0;content:""}.row:after{clear:both}[class*="span"]{float:left;min-height:1px;margin-left:30px}.container,.navbar-static-top .container,.navbar-fixed-top .container,.navbar-fixed-bottom .container{width:1170px}.span12{width:1170px}.span11{width:1070px}.span10{width:970px}.span9{width:870px}.span8{width:770px}.span7{width:670px}.span6{width:570px}.span5{width:470px}.span4{width:370px}.span3{width:270px}.span2{width:170px}.span1{width:70px}.offset12{margin-left:1230px}.offset11{margin-left:1130px}.offset10{margin-left:1030px}.offset9{margin-left:930px}.offset8{margin-left:830px}.offset7{margin-left:730px}.offset6{margin-left:630px}.offset5{margin-left:530px}.offset4{margin-left:430px}.offset3{margin-left:330px}.offset2{margin-left:230px}.offset1{margin-left:130px}.row-fluid{width:100%;*zoom:1}.row-fluid:before,.row-fluid:after{display:table;line-height:0;content:""}.row-fluid:after{clear:both}.row-fluid [class*="span"]{display:block;float:left;width:100%;min-height:30px;margin-left:2.564102564102564%;*margin-left:2.5109110747408616%;-webkit-box-sizing:border-box;-moz-box-sizing:border-box;box-sizing:border-box}.row-fluid [class*="span"]:first-child{margin-left:0}.row-fluid .controls-row [class*="span"]+[class*="span"]{margin-left:2.564102564102564%}.row-fluid .span12{width:100%;*width:99.94680851063829%}.row-fluid .span11{width:91.45299145299145%;*width:91.39979996362975%}.row-fluid .span10{width:82.90598290598291%;*width:82.8527914166212%}.row-fluid .span9{width:74.35897435897436%;*width:74.30578286961266%}.row-fluid .span8{width:65.81196581196582%;*width:65.75877432260411%}.row-fluid .span7{width:57.26495726495726%;*width:57.21176577559556%}.row-fluid .span6{width:48.717948717948715%;*width:48.664757228587014%}.row-fluid .span5{width:40.17094017094017%;*width:40.11774868157847%}.row-fluid .span4{width:31.623931623931625%;*width:31.570740134569924%}.row-fluid .span3{width:23.076923076923077%;*width:23.023731587561375%}.row-fluid .span2{width:14.52991452991453%;*width:14.476723040552828%}.row-fluid .span1{width:5.982905982905983%;*width:5.929714493544281%}.row-fluid .offset12{margin-left:105.12820512820512%;*margin-left:105.02182214948171%}.row-fluid .offset12:first-child{margin-left:102.56410256410257%;*margin-left:102.45771958537915%}.row-fluid .offset11{margin-left:96.58119658119658%;*margin-left:96.47481360247316%}.row-fluid .offset11:first-child{margin-left:94.01709401709402%;*margin-left:93.91071103837061%}.row-fluid .offset10{margin-left:88.03418803418803%;*margin-left:87.92780505546462%}.row-fluid .offset10:first-child{margin-left:85.47008547008548%;*margin-left:85.36370249136206%}.row-fluid .offset9{margin-left:79.48717948717949%;*margin-left:79.38079650845607%}.row-fluid .offset9:first-child{margin-left:76.92307692307693%;*margin-left:76.81669394435352%}.row-fluid .offset8{margin-left:70.94017094017094%;*margin-left:70.83378796144753%}.row-fluid .offset8:first-child{margin-left:68.37606837606839%;*margin-left:68.26968539734497%}.row-fluid .offset7{margin-left:62.393162393162385%;*margin-left:62.28677941443899%}.row-fluid .offset7:first-child{margin-left:59.82905982905982%;*margin-left:59.72267685033642%}.row-fluid .offset6{margin-left:53.84615384615384%;*margin-left:53.739770867430444%}.row-fluid .offset6:first-child{margin-left:51.28205128205128%;*margin-left:51.175668303327875%}.row-fluid .offset5{margin-left:45.299145299145295%;*margin-left:45.1927623204219%}.row-fluid .offset5:first-child{margin-left:42.73504273504273%;*margin-left:42.62865975631933%}.row-fluid .offset4{margin-left:36.75213675213675%;*margin-left:36.645753773413354%}.row-fluid .offset4:first-child{margin-left:34.18803418803419%;*margin-left:34.081651209310785%}.row-fluid .offset3{margin-left:28.205128205128204%;*margin-left:28.0987452264048%}.row-fluid .offset3:first-child{margin-left:25.641025641025642%;*margin-left:25.53464266230224%}.row-fluid .offset2{margin-left:19.65811965811966%;*margin-left:19.551736679396257%}.row-fluid .offset2:first-child{margin-left:17.094017094017094%;*margin-left:16.98763411529369%}.row-fluid .offset1{margin-left:11.11111111111111%;*margin-left:11.004728132387708%}.row-fluid .offset1:first-child{margin-left:8.547008547008547%;*margin-left:8.440625568285142%}input,textarea,.uneditable-input{margin-left:0}.controls-row [class*="span"]+[class*="span"]{margin-left:30px}input.span12,textarea.span12,.uneditable-input.span12{width:1156px}input.span11,textarea.span11,.uneditable-input.span11{width:1056px}input.span10,textarea.span10,.uneditable-input.span10{width:956px}input.span9,textarea.span9,.uneditable-input.span9{width:856px}input.span8,textarea.span8,.uneditable-input.span8{width:756px}input.span7,textarea.span7,.uneditable-input.span7{width:656px}input.span6,textarea.span6,.uneditable-input.span6{width:556px}input.span5,textarea.span5,.uneditable-input.span5{width:456px}input.span4,textarea.span4,.uneditable-input.span4{width:356px}input.span3,textarea.span3,.uneditable-input.span3{width:256px}input.span2,textarea.span2,.uneditable-input.span2{width:156px}input.span1,textarea.span1,.uneditable-input.span1{width:56px}.thumbnails{margin-left:-30px}.thumbnails>li{margin-left:30px}.row-fluid .thumbnails{margin-left:0}}@media(min-width:768px) and (max-width:979px){.row{margin-left:-20px;*zoom:1}.row:before,.row:after{display:table;line-height:0;content:""}.row:after{clear:both}[class*="span"]{float:left;min-height:1px;margin-left:20px}.container,.navbar-static-top .container,.navbar-fixed-top .container,.navbar-fixed-bottom .container{width:724px}.span12{width:724px}.span11{width:662px}.span10{width:600px}.span9{width:538px}.span8{width:476px}.span7{width:414px}.span6{width:352px}.span5{width:290px}.span4{width:228px}.span3{width:166px}.span2{width:104px}.span1{width:42px}.offset12{margin-left:764px}.offset11{margin-left:702px}.offset10{margin-left:640px}.offset9{margin-left:578px}.offset8{margin-left:516px}.offset7{margin-left:454px}.offset6{margin-left:392px}.offset5{margin-left:330px}.offset4{margin-left:268px}.offset3{margin-left:206px}.offset2{margin-left:144px}.offset1{margin-left:82px}.row-fluid{width:100%;*zoom:1}.row-fluid:before,.row-fluid:after{display:table;line-height:0;content:""}.row-fluid:after{clear:both}.row-fluid [class*="span"]{display:block;float:left;width:100%;min-height:30px;margin-left:2.7624309392265194%;*margin-left:2.709239449864817%;-webkit-box-sizing:border-box;-moz-box-sizing:border-box;box-sizing:border-box}.row-fluid [class*="span"]:first-child{margin-left:0}.row-fluid .controls-row [class*="span"]+[class*="span"]{margin-left:2.7624309392265194%}.row-fluid .span12{width:100%;*width:99.94680851063829%}.row-fluid .span11{width:91.43646408839778%;*width:91.38327259903608%}.row-fluid .span10{width:82.87292817679558%;*width:82.81973668743387%}.row-fluid .span9{width:74.30939226519337%;*width:74.25620077583166%}.row-fluid .span8{width:65.74585635359117%;*width:65.69266486422946%}.row-fluid .span7{width:57.18232044198895%;*width:57.12912895262725%}.row-fluid .span6{width:48.61878453038674%;*width:48.56559304102504%}.row-fluid .span5{width:40.05524861878453%;*width:40.00205712942283%}.row-fluid .span4{width:31.491712707182323%;*width:31.43852121782062%}.row-fluid .span3{width:22.92817679558011%;*width:22.87498530621841%}.row-fluid .span2{width:14.3646408839779%;*width:14.311449394616199%}.row-fluid .span1{width:5.801104972375691%;*width:5.747913483013988%}.row-fluid .offset12{margin-left:105.52486187845304%;*margin-left:105.41847889972962%}.row-fluid .offset12:first-child{margin-left:102.76243093922652%;*margin-left:102.6560479605031%}.row-fluid .offset11{margin-left:96.96132596685082%;*margin-left:96.8549429881274%}.row-fluid .offset11:first-child{margin-left:94.1988950276243%;*margin-left:94.09251204890089%}.row-fluid .offset10{margin-left:88.39779005524862%;*margin-left:88.2914070765252%}.row-fluid .offset10:first-child{margin-left:85.6353591160221%;*margin-left:85.52897613729868%}.row-fluid .offset9{margin-left:79.8342541436464%;*margin-left:79.72787116492299%}.row-fluid .offset9:first-child{margin-left:77.07182320441989%;*margin-left:76.96544022569647%}.row-fluid .offset8{margin-left:71.2707182320442%;*margin-left:71.16433525332079%}.row-fluid .offset8:first-child{margin-left:68.50828729281768%;*margin-left:68.40190431409427%}.row-fluid .offset7{margin-left:62.70718232044199%;*margin-left:62.600799341718584%}.row-fluid .offset7:first-child{margin-left:59.94475138121547%;*margin-left:59.838368402492065%}.row-fluid .offset6{margin-left:54.14364640883978%;*margin-left:54.037263430116376%}.row-fluid .offset6:first-child{margin-left:51.38121546961326%;*margin-left:51.27483249088986%}.row-fluid .offset5{margin-left:45.58011049723757%;*margin-left:45.47372751851417%}.row-fluid .offset5:first-child{margin-left:42.81767955801105%;*margin-left:42.71129657928765%}.row-fluid .offset4{margin-left:37.01657458563536%;*margin-left:36.91019160691196%}.row-fluid .offset4:first-child{margin-left:34.25414364640884%;*margin-left:34.14776066768544%}.row-fluid .offset3{margin-left:28.45303867403315%;*margin-left:28.346655695309746%}.row-fluid .offset3:first-child{margin-left:25.69060773480663%;*margin-left:25.584224756083227%}.row-fluid .offset2{margin-left:19.88950276243094%;*margin-left:19.783119783707537%}.row-fluid .offset2:first-child{margin-left:17.12707182320442%;*margin-left:17.02068884448102%}.row-fluid .offset1{margin-left:11.32596685082873%;*margin-left:11.219583872105325%}.row-fluid .offset1:first-child{margin-left:8.56353591160221%;*margin-left:8.457152932878806%}input,textarea,.uneditable-input{margin-left:0}.controls-row [class*="span"]+[class*="span"]{margin-left:20px}input.span12,textarea.span12,.uneditable-input.span12{width:710px}input.span11,textarea.span11,.uneditable-input.span11{width:648px}input.span10,textarea.span10,.uneditable-input.span10{width:586px}input.span9,textarea.span9,.uneditable-input.span9{width:524px}input.span8,textarea.span8,.uneditable-input.span8{width:462px}input.span7,textarea.span7,.uneditable-input.span7{width:400px}input.span6,textarea.span6,.uneditable-input.span6{width:338px}input.span5,textarea.span5,.uneditable-input.span5{width:276px}input.span4,textarea.span4,.uneditable-input.span4{width:214px}input.span3,textarea.span3,.uneditable-input.span3{width:152px}input.span2,textarea.span2,.uneditable-input.span2{width:90px}input.span1,textarea.span1,.uneditable-input.span1{width:28px}}@media(max-width:767px){body{padding-right:20px;padding-left:20px}.navbar-fixed-top,.navbar-fixed-bottom,.navbar-static-top{margin-right:-20px;margin-left:-20px}.container-fluid{padding:0}.dl-horizontal dt{float:none;width:auto;clear:none;text-align:left}.dl-horizontal dd{margin-left:0}.container{width:auto}.row-fluid{width:100%}.row,.thumbnails{margin-left:0}.thumbnails>li{float:none;margin-left:0}[class*="span"],.uneditable-input[class*="span"],.row-fluid [class*="span"]{display:block;float:none;width:100%;margin-left:0;-webkit-box-sizing:border-box;-moz-box-sizing:border-box;box-sizing:border-box}.span12,.row-fluid .span12{width:100%;-webkit-box-sizing:border-box;-moz-box-sizing:border-box;box-sizing:border-box}.row-fluid [class*="offset"]:first-child{margin-left:0}.input-large,.input-xlarge,.input-xxlarge,input[class*="span"],select[class*="span"],textarea[class*="span"],.uneditable-input{display:block;width:100%;min-height:30px;-webkit-box-sizing:border-box;-moz-box-sizing:border-box;box-sizing:border-box}.input-prepend input,.input-append input,.input-prepend input[class*="span"],.input-append input[class*="span"]{display:inline-block;width:auto}.controls-row [class*="span"]+[class*="span"]{margin-left:0}.modal{position:fixed;top:20px;right:20px;left:20px;width:auto;margin:0}.modal.fade{top:-100px}.modal.fade.in{top:20px}}@media(max-width:480px){.nav-collapse{-webkit-transform:translate3d(0,0,0)}.page-header h1 small{display:block;line-height:20px}input[type="checkbox"],input[type="radio"]{border:1px solid #ccc}.form-horizontal .control-label{float:none;width:auto;padding-top:0;text-align:left}.form-horizontal .controls{margin-left:0}.form-horizontal .control-list{padding-top:0}.form-horizontal .form-actions{padding-right:10px;padding-left:10px}.media .pull-left,.media .pull-right{display:block;float:none;margin-bottom:10px}.media-object{margin-right:0;margin-left:0}.modal{top:10px;right:10px;left:10px}.modal-header .close{padding:10px;margin:-10px}.carousel-caption{position:static}}@media(max-width:979px){body{padding-top:0}.navbar-fixed-top,.navbar-fixed-bottom{position:static}.navbar-fixed-top{margin-bottom:20px}.navbar-fixed-bottom{margin-top:20px}.navbar-fixed-top .navbar-inner,.navbar-fixed-bottom .navbar-inner{padding:5px}.navbar .container{width:auto;padding:0}.navbar .brand{padding-right:10px;padding-left:10px;margin:0 0 0 -5px}.nav-collapse{clear:both}.nav-collapse .nav{float:none;margin:0 0 10px}.nav-collapse .nav>li{float:none}.nav-collapse .nav>li>a{margin-bottom:2px}.nav-collapse .nav>.divider-vertical{display:none}.nav-collapse .nav .nav-header{color:#777;text-shadow:none}.nav-collapse .nav>li>a,.nav-collapse .dropdown-menu a{padding:9px 15px;font-weight:bold;color:#777;-webkit-border-radius:3px;-moz-border-radius:3px;border-radius:3px}.nav-collapse .btn{padding:4px 10px 4px;font-weight:normal;-webkit-border-radius:4px;-moz-border-radius:4px;border-radius:4px}.nav-collapse .dropdown-menu li+li a{margin-bottom:2px}.nav-collapse .nav>li>a:hover,.nav-collapse .dropdown-menu a:hover{background-color:#f2f2f2}.navbar-inverse .nav-collapse .nav>li>a,.navbar-inverse .nav-collapse .dropdown-menu a{color:#999}.navbar-inverse .nav-collapse .nav>li>a:hover,.navbar-inverse .nav-collapse .dropdown-menu a:hover{background-color:#111}.nav-collapse.in .btn-group{padding:0;margin-top:5px}.nav-collapse .dropdown-menu{position:static;top:auto;left:auto;display:none;float:none;max-width:none;padding:0;margin:0 15px;background-color:transparent;border:0;-webkit-border-radius:0;-moz-border-radius:0;border-radius:0;-webkit-box-shadow:none;-moz-box-shadow:none;box-shadow:none}.nav-collapse .open>.dropdown-menu{display:block}.nav-collapse .dropdown-menu:before,.nav-collapse .dropdown-menu:after{display:none}.nav-collapse .dropdown-menu .divider{display:none}.nav-collapse .nav>li>.dropdown-menu:before,.nav-collapse .nav>li>.dropdown-menu:after{display:none}.nav-collapse .navbar-form,.nav-collapse .navbar-search{float:none;padding:10px 15px;margin:10px 0;border-top:1px solid #f2f2f2;border-bottom:1px solid #f2f2f2;-webkit-box-shadow:inset 0 1px 0 rgba(255,255,255,0.1),0 1px 0 rgba(255,255,255,0.1);-moz-box-shadow:inset 0 1px 0 rgba(255,255,255,0.1),0 1px 0 rgba(255,255,255,0.1);box-shadow:inset 0 1px 0 rgba(255,255,255,0.1),0 1px 0 rgba(255,255,255,0.1)}.navbar-inverse .nav-collapse .navbar-form,.navbar-inverse .nav-collapse .navbar-search{border-top-color:#111;border-bottom-color:#111}.navbar .nav-collapse .nav.pull-right{float:none;margin-left:0}.nav-collapse,.nav-collapse.collapse{height:0;overflow:hidden}.navbar .btn-navbar{display:block}.navbar-static .navbar-inner{padding-right:10px;padding-left:10px}}@media(min-width:980px){.nav-collapse.collapse{height:auto!important;overflow:visible!important}} diff --git a/website/css/bootstrap.css b/website/css/bootstrap.css new file mode 100644 index 00000000..5307afe7 --- /dev/null +++ b/website/css/bootstrap.css @@ -0,0 +1,6039 @@ +/*! + * Bootstrap v2.2.2 + * + * Copyright 2012 Twitter, Inc + * Licensed under the Apache License v2.0 + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Designed and built with all the love in the world @twitter by @mdo and @fat. + */ + +article, +aside, +details, +figcaption, +figure, +footer, +header, +hgroup, +nav, +section { + display: block; +} + +audio, +canvas, +video { + display: inline-block; + *display: inline; + *zoom: 1; +} + +audio:not([controls]) { + display: none; +} + +html { + font-size: 100%; + -webkit-text-size-adjust: 100%; + -ms-text-size-adjust: 100%; +} + +a:focus { + outline: thin dotted #333; + outline: 5px auto -webkit-focus-ring-color; + outline-offset: -2px; +} + +a:hover, +a:active { + outline: 0; +} + +sub, +sup { + position: relative; + font-size: 75%; + line-height: 0; + vertical-align: baseline; +} + +sup { + top: -0.5em; +} + +sub { + bottom: -0.25em; +} + +img { + width: auto\9; + height: auto; + max-width: 100%; + vertical-align: middle; + border: 0; + -ms-interpolation-mode: bicubic; +} + +#map_canvas img, +.google-maps img { + max-width: none; +} + +button, +input, +select, +textarea { + margin: 0; + font-size: 100%; + vertical-align: middle; +} + +button, +input { + *overflow: visible; + line-height: normal; +} + +button::-moz-focus-inner, +input::-moz-focus-inner { + padding: 0; + border: 0; +} + +button, +html input[type="button"], +input[type="reset"], +input[type="submit"] { + cursor: pointer; + -webkit-appearance: button; +} + +label, +select, +button, +input[type="button"], +input[type="reset"], +input[type="submit"], +input[type="radio"], +input[type="checkbox"] { + cursor: pointer; +} + +input[type="search"] { + -webkit-box-sizing: content-box; + -moz-box-sizing: content-box; + box-sizing: content-box; + -webkit-appearance: textfield; +} + +input[type="search"]::-webkit-search-decoration, +input[type="search"]::-webkit-search-cancel-button { + -webkit-appearance: none; +} + +textarea { + overflow: auto; + vertical-align: top; +} + +@media print { + * { + color: #000 !important; + text-shadow: none !important; + background: transparent !important; + box-shadow: none !important; + } + a, + a:visited { + text-decoration: underline; + } + a[href]:after { + content: " (" attr(href) ")"; + } + abbr[title]:after { + content: " (" attr(title) ")"; + } + .ir a:after, + a[href^="javascript:"]:after, + a[href^="#"]:after { + content: ""; + } + pre, + blockquote { + border: 1px solid #999; + page-break-inside: avoid; + } + thead { + display: table-header-group; + } + tr, + img { + page-break-inside: avoid; + } + img { + max-width: 100% !important; + } + @page { + margin: 0.5cm; + } + p, + h2, + h3 { + orphans: 3; + widows: 3; + } + h2, + h3 { + page-break-after: avoid; + } +} + +.clearfix { + *zoom: 1; +} + +.clearfix:before, +.clearfix:after { + display: table; + line-height: 0; + content: ""; +} + +.clearfix:after { + clear: both; +} + +.hide-text { + font: 0/0 a; + color: transparent; + text-shadow: none; + background-color: transparent; + border: 0; +} + +.input-block-level { + display: block; + width: 100%; + min-height: 30px; + -webkit-box-sizing: border-box; + -moz-box-sizing: border-box; + box-sizing: border-box; +} + +body { + margin: 0; + font-family: "Helvetica Neue", Helvetica, Arial, sans-serif; + font-size: 14px; + line-height: 20px; + color: #333333; + background-color: #ffffff; +} + +a { + color: #0088cc; + text-decoration: none; +} + +a:hover { + color: #005580; + text-decoration: underline; +} + +.img-rounded { + -webkit-border-radius: 6px; + -moz-border-radius: 6px; + border-radius: 6px; +} + +.img-polaroid { + padding: 4px; + background-color: #fff; + border: 1px solid #ccc; + border: 1px solid rgba(0, 0, 0, 0.2); + -webkit-box-shadow: 0 1px 3px rgba(0, 0, 0, 0.1); + -moz-box-shadow: 0 1px 3px rgba(0, 0, 0, 0.1); + box-shadow: 0 1px 3px rgba(0, 0, 0, 0.1); +} + +.img-circle { + -webkit-border-radius: 500px; + -moz-border-radius: 500px; + border-radius: 500px; +} + +.row { + margin-left: -20px; + *zoom: 1; +} + +.row:before, +.row:after { + display: table; + line-height: 0; + content: ""; +} + +.row:after { + clear: both; +} + +[class*="span"] { + float: left; + min-height: 1px; + margin-left: 20px; +} + +.container, +.navbar-static-top .container, +.navbar-fixed-top .container, +.navbar-fixed-bottom .container { + width: 940px; +} + +.span12 { + width: 940px; +} + +.span11 { + width: 860px; +} + +.span10 { + width: 780px; +} + +.span9 { + width: 700px; +} + +.span8 { + width: 620px; +} + +.span7 { + width: 540px; +} + +.span6 { + width: 460px; +} + +.span5 { + width: 380px; +} + +.span4 { + width: 300px; +} + +.span3 { + width: 220px; +} + +.span2 { + width: 140px; +} + +.span1 { + width: 60px; +} + +.offset12 { + margin-left: 980px; +} + +.offset11 { + margin-left: 900px; +} + +.offset10 { + margin-left: 820px; +} + +.offset9 { + margin-left: 740px; +} + +.offset8 { + margin-left: 660px; +} + +.offset7 { + margin-left: 580px; +} + +.offset6 { + margin-left: 500px; +} + +.offset5 { + margin-left: 420px; +} + +.offset4 { + margin-left: 340px; +} + +.offset3 { + margin-left: 260px; +} + +.offset2 { + margin-left: 180px; +} + +.offset1 { + margin-left: 100px; +} + +.row-fluid { + width: 100%; + *zoom: 1; +} + +.row-fluid:before, +.row-fluid:after { + display: table; + line-height: 0; + content: ""; +} + +.row-fluid:after { + clear: both; +} + +.row-fluid [class*="span"] { + display: block; + float: left; + width: 100%; + min-height: 30px; + margin-left: 2.127659574468085%; + *margin-left: 2.074468085106383%; + -webkit-box-sizing: border-box; + -moz-box-sizing: border-box; + box-sizing: border-box; +} + +.row-fluid [class*="span"]:first-child { + margin-left: 0; +} + +.row-fluid .controls-row [class*="span"] + [class*="span"] { + margin-left: 2.127659574468085%; +} + +.row-fluid .span12 { + width: 100%; + *width: 99.94680851063829%; +} + +.row-fluid .span11 { + width: 91.48936170212765%; + *width: 91.43617021276594%; +} + +.row-fluid .span10 { + width: 82.97872340425532%; + *width: 82.92553191489361%; +} + +.row-fluid .span9 { + width: 74.46808510638297%; + *width: 74.41489361702126%; +} + +.row-fluid .span8 { + width: 65.95744680851064%; + *width: 65.90425531914893%; +} + +.row-fluid .span7 { + width: 57.44680851063829%; + *width: 57.39361702127659%; +} + +.row-fluid .span6 { + width: 48.93617021276595%; + *width: 48.88297872340425%; +} + +.row-fluid .span5 { + width: 40.42553191489362%; + *width: 40.37234042553192%; +} + +.row-fluid .span4 { + width: 31.914893617021278%; + *width: 31.861702127659576%; +} + +.row-fluid .span3 { + width: 23.404255319148934%; + *width: 23.351063829787233%; +} + +.row-fluid .span2 { + width: 14.893617021276595%; + *width: 14.840425531914894%; +} + +.row-fluid .span1 { + width: 6.382978723404255%; + *width: 6.329787234042553%; +} + +.row-fluid .offset12 { + margin-left: 104.25531914893617%; + *margin-left: 104.14893617021275%; +} + +.row-fluid .offset12:first-child { + margin-left: 102.12765957446808%; + *margin-left: 102.02127659574467%; +} + +.row-fluid .offset11 { + margin-left: 95.74468085106382%; + *margin-left: 95.6382978723404%; +} + +.row-fluid .offset11:first-child { + margin-left: 93.61702127659574%; + *margin-left: 93.51063829787232%; +} + +.row-fluid .offset10 { + margin-left: 87.23404255319149%; + *margin-left: 87.12765957446807%; +} + +.row-fluid .offset10:first-child { + margin-left: 85.1063829787234%; + *margin-left: 84.99999999999999%; +} + +.row-fluid .offset9 { + margin-left: 78.72340425531914%; + *margin-left: 78.61702127659572%; +} + +.row-fluid .offset9:first-child { + margin-left: 76.59574468085106%; + *margin-left: 76.48936170212764%; +} + +.row-fluid .offset8 { + margin-left: 70.2127659574468%; + *margin-left: 70.10638297872339%; +} + +.row-fluid .offset8:first-child { + margin-left: 68.08510638297872%; + *margin-left: 67.9787234042553%; +} + +.row-fluid .offset7 { + margin-left: 61.70212765957446%; + *margin-left: 61.59574468085106%; +} + +.row-fluid .offset7:first-child { + margin-left: 59.574468085106375%; + *margin-left: 59.46808510638297%; +} + +.row-fluid .offset6 { + margin-left: 53.191489361702125%; + *margin-left: 53.085106382978715%; +} + +.row-fluid .offset6:first-child { + margin-left: 51.063829787234035%; + *margin-left: 50.95744680851063%; +} + +.row-fluid .offset5 { + margin-left: 44.68085106382979%; + *margin-left: 44.57446808510638%; +} + +.row-fluid .offset5:first-child { + margin-left: 42.5531914893617%; + *margin-left: 42.4468085106383%; +} + +.row-fluid .offset4 { + margin-left: 36.170212765957444%; + *margin-left: 36.06382978723405%; +} + +.row-fluid .offset4:first-child { + margin-left: 34.04255319148936%; + *margin-left: 33.93617021276596%; +} + +.row-fluid .offset3 { + margin-left: 27.659574468085104%; + *margin-left: 27.5531914893617%; +} + +.row-fluid .offset3:first-child { + margin-left: 25.53191489361702%; + *margin-left: 25.425531914893618%; +} + +.row-fluid .offset2 { + margin-left: 19.148936170212764%; + *margin-left: 19.04255319148936%; +} + +.row-fluid .offset2:first-child { + margin-left: 17.02127659574468%; + *margin-left: 16.914893617021278%; +} + +.row-fluid .offset1 { + margin-left: 10.638297872340425%; + *margin-left: 10.53191489361702%; +} + +.row-fluid .offset1:first-child { + margin-left: 8.51063829787234%; + *margin-left: 8.404255319148938%; +} + +[class*="span"].hide, +.row-fluid [class*="span"].hide { + display: none; +} + +[class*="span"].pull-right, +.row-fluid [class*="span"].pull-right { + float: right; +} + +.container { + margin-right: auto; + margin-left: auto; + *zoom: 1; +} + +.container:before, +.container:after { + display: table; + line-height: 0; + content: ""; +} + +.container:after { + clear: both; +} + +.container-fluid { + padding-right: 20px; + padding-left: 20px; + *zoom: 1; +} + +.container-fluid:before, +.container-fluid:after { + display: table; + line-height: 0; + content: ""; +} + +.container-fluid:after { + clear: both; +} + +p { + margin: 0 0 10px; +} + +.lead { + margin-bottom: 20px; + font-size: 21px; + font-weight: 200; + line-height: 30px; +} + +small { + font-size: 85%; +} + +strong { + font-weight: bold; +} + +em { + font-style: italic; +} + +cite { + font-style: normal; +} + +.muted { + color: #999999; +} + +a.muted:hover { + color: #808080; +} + +.text-warning { + color: #c09853; +} + +a.text-warning:hover { + color: #a47e3c; +} + +.text-error { + color: #b94a48; +} + +a.text-error:hover { + color: #953b39; +} + +.text-info { + color: #3a87ad; +} + +a.text-info:hover { + color: #2d6987; +} + +.text-success { + color: #468847; +} + +a.text-success:hover { + color: #356635; +} + +h1, +h2, +h3, +h4, +h5, +h6 { + margin: 10px 0; + font-family: inherit; + font-weight: bold; + line-height: 20px; + color: inherit; + text-rendering: optimizelegibility; +} + +h1 small, +h2 small, +h3 small, +h4 small, +h5 small, +h6 small { + font-weight: normal; + line-height: 1; + color: #999999; +} + +h1, +h2, +h3 { + line-height: 40px; +} + +h1 { + font-size: 38.5px; +} + +h2 { + font-size: 31.5px; +} + +h3 { + font-size: 24.5px; +} + +h4 { + font-size: 17.5px; +} + +h5 { + font-size: 14px; +} + +h6 { + font-size: 11.9px; +} + +h1 small { + font-size: 24.5px; +} + +h2 small { + font-size: 17.5px; +} + +h3 small { + font-size: 14px; +} + +h4 small { + font-size: 14px; +} + +.page-header { + padding-bottom: 9px; + margin: 20px 0 30px; + border-bottom: 1px solid #eeeeee; +} + +ul, +ol { + padding: 0; + margin: 0 0 10px 25px; +} + +ul ul, +ul ol, +ol ol, +ol ul { + margin-bottom: 0; +} + +li { + line-height: 20px; +} + +ul.unstyled, +ol.unstyled { + margin-left: 0; + list-style: none; +} + +ul.inline, +ol.inline { + margin-left: 0; + list-style: none; +} + +ul.inline > li, +ol.inline > li { + display: inline-block; + padding-right: 5px; + padding-left: 5px; +} + +dl { + margin-bottom: 20px; +} + +dt, +dd { + line-height: 20px; +} + +dt { + font-weight: bold; +} + +dd { + margin-left: 10px; +} + +.dl-horizontal { + *zoom: 1; +} + +.dl-horizontal:before, +.dl-horizontal:after { + display: table; + line-height: 0; + content: ""; +} + +.dl-horizontal:after { + clear: both; +} + +.dl-horizontal dt { + float: left; + width: 160px; + overflow: hidden; + clear: left; + text-align: right; + text-overflow: ellipsis; + white-space: nowrap; +} + +.dl-horizontal dd { + margin-left: 180px; +} + +hr { + margin: 20px 0; + border: 0; + border-top: 1px solid #eeeeee; + border-bottom: 1px solid #ffffff; +} + +abbr[title], +abbr[data-original-title] { + cursor: help; + border-bottom: 1px dotted #999999; +} + +abbr.initialism { + font-size: 90%; + text-transform: uppercase; +} + +blockquote { + padding: 0 0 0 15px; + margin: 0 0 20px; + border-left: 5px solid #eeeeee; +} + +blockquote p { + margin-bottom: 0; +# font-size: 16px; + font-weight: 300; +# line-height: 25px; +} + +blockquote small { + display: block; + line-height: 20px; + color: #999999; +} + +blockquote small:before { + content: '\2014 \00A0'; +} + +blockquote.pull-right { + float: right; + padding-right: 15px; + padding-left: 0; + border-right: 5px solid #eeeeee; + border-left: 0; +} + +blockquote.pull-right p, +blockquote.pull-right small { + text-align: right; +} + +blockquote.pull-right small:before { + content: ''; +} + +blockquote.pull-right small:after { + content: '\00A0 \2014'; +} + +q:before, +q:after, +blockquote:before, +blockquote:after { + content: ""; +} + +address { + display: block; + margin-bottom: 20px; + font-style: normal; + line-height: 20px; +} + +code, +pre { + padding: 0 3px 2px; + font-family: Monaco, Menlo, Consolas, "Courier New", monospace; + font-size: 12px; + color: #333333; + -webkit-border-radius: 3px; + -moz-border-radius: 3px; + border-radius: 3px; +} + +code { + padding: 2px 4px; + color: #d14; + white-space: nowrap; + background-color: #f7f7f9; + border: 1px solid #e1e1e8; +} + +pre { + display: block; + padding: 9.5px; + margin: 0 0 10px; + font-size: 13px; + line-height: 20px; + word-break: break-all; + word-wrap: break-word; + white-space: pre; + white-space: pre-wrap; + background-color: #f5f5f5; + border: 1px solid #ccc; + border: 1px solid rgba(0, 0, 0, 0.15); + -webkit-border-radius: 4px; + -moz-border-radius: 4px; + border-radius: 4px; +} + +pre.prettyprint { + margin-bottom: 20px; +} + +pre code { + padding: 0; + color: inherit; + white-space: pre; + white-space: pre-wrap; + background-color: transparent; + border: 0; +} + +.pre-scrollable { + max-height: 340px; + overflow-y: scroll; +} + +form { + margin: 0 0 20px; +} + +fieldset { + padding: 0; + margin: 0; + border: 0; +} + +legend { + display: block; + width: 100%; + padding: 0; + margin-bottom: 20px; + font-size: 21px; + line-height: 40px; + color: #333333; + border: 0; + border-bottom: 1px solid #e5e5e5; +} + +legend small { + font-size: 15px; + color: #999999; +} + +label, +input, +button, +select, +textarea { + font-size: 14px; + font-weight: normal; + line-height: 20px; +} + +input, +button, +select, +textarea { + font-family: "Helvetica Neue", Helvetica, Arial, sans-serif; +} + +label { + display: block; + margin-bottom: 5px; +} + +select, +textarea, +input[type="text"], +input[type="password"], +input[type="datetime"], +input[type="datetime-local"], +input[type="date"], +input[type="month"], +input[type="time"], +input[type="week"], +input[type="number"], +input[type="email"], +input[type="url"], +input[type="search"], +input[type="tel"], +input[type="color"], +.uneditable-input { + display: inline-block; + height: 20px; + padding: 4px 6px; + margin-bottom: 10px; + font-size: 14px; + line-height: 20px; + color: #555555; + vertical-align: middle; + -webkit-border-radius: 4px; + -moz-border-radius: 4px; + border-radius: 4px; +} + +input, +textarea, +.uneditable-input { + width: 206px; +} + +textarea { + height: auto; +} + +textarea, +input[type="text"], +input[type="password"], +input[type="datetime"], +input[type="datetime-local"], +input[type="date"], +input[type="month"], +input[type="time"], +input[type="week"], +input[type="number"], +input[type="email"], +input[type="url"], +input[type="search"], +input[type="tel"], +input[type="color"], +.uneditable-input { + background-color: #ffffff; + border: 1px solid #cccccc; + -webkit-box-shadow: inset 0 1px 1px rgba(0, 0, 0, 0.075); + -moz-box-shadow: inset 0 1px 1px rgba(0, 0, 0, 0.075); + box-shadow: inset 0 1px 1px rgba(0, 0, 0, 0.075); + -webkit-transition: border linear 0.2s, box-shadow linear 0.2s; + -moz-transition: border linear 0.2s, box-shadow linear 0.2s; + -o-transition: border linear 0.2s, box-shadow linear 0.2s; + transition: border linear 0.2s, box-shadow linear 0.2s; +} + +textarea:focus, +input[type="text"]:focus, +input[type="password"]:focus, +input[type="datetime"]:focus, +input[type="datetime-local"]:focus, +input[type="date"]:focus, +input[type="month"]:focus, +input[type="time"]:focus, +input[type="week"]:focus, +input[type="number"]:focus, +input[type="email"]:focus, +input[type="url"]:focus, +input[type="search"]:focus, +input[type="tel"]:focus, +input[type="color"]:focus, +.uneditable-input:focus { + border-color: rgba(82, 168, 236, 0.8); + outline: 0; + outline: thin dotted \9; + /* IE6-9 */ + + -webkit-box-shadow: inset 0 1px 1px rgba(0, 0, 0, 0.075), 0 0 8px rgba(82, 168, 236, 0.6); + -moz-box-shadow: inset 0 1px 1px rgba(0, 0, 0, 0.075), 0 0 8px rgba(82, 168, 236, 0.6); + box-shadow: inset 0 1px 1px rgba(0, 0, 0, 0.075), 0 0 8px rgba(82, 168, 236, 0.6); +} + +input[type="radio"], +input[type="checkbox"] { + margin: 4px 0 0; + margin-top: 1px \9; + *margin-top: 0; + line-height: normal; +} + +input[type="file"], +input[type="image"], +input[type="submit"], +input[type="reset"], +input[type="button"], +input[type="radio"], +input[type="checkbox"] { + width: auto; +} + +select, +input[type="file"] { + height: 30px; + /* In IE7, the height of the select element cannot be changed by height, only font-size */ + + *margin-top: 4px; + /* For IE7, add top margin to align select with labels */ + + line-height: 30px; +} + +select { + width: 220px; + background-color: #ffffff; + border: 1px solid #cccccc; +} + +select[multiple], +select[size] { + height: auto; +} + +select:focus, +input[type="file"]:focus, +input[type="radio"]:focus, +input[type="checkbox"]:focus { + outline: thin dotted #333; + outline: 5px auto -webkit-focus-ring-color; + outline-offset: -2px; +} + +.uneditable-input, +.uneditable-textarea { + color: #999999; + cursor: not-allowed; + background-color: #fcfcfc; + border-color: #cccccc; + -webkit-box-shadow: inset 0 1px 2px rgba(0, 0, 0, 0.025); + -moz-box-shadow: inset 0 1px 2px rgba(0, 0, 0, 0.025); + box-shadow: inset 0 1px 2px rgba(0, 0, 0, 0.025); +} + +.uneditable-input { + overflow: hidden; + white-space: nowrap; +} + +.uneditable-textarea { + width: auto; + height: auto; +} + +input:-moz-placeholder, +textarea:-moz-placeholder { + color: #999999; +} + +input:-ms-input-placeholder, +textarea:-ms-input-placeholder { + color: #999999; +} + +input::-webkit-input-placeholder, +textarea::-webkit-input-placeholder { + color: #999999; +} + +.radio, +.checkbox { + min-height: 20px; + padding-left: 20px; +} + +.radio input[type="radio"], +.checkbox input[type="checkbox"] { + float: left; + margin-left: -20px; +} + +.controls > .radio:first-child, +.controls > .checkbox:first-child { + padding-top: 5px; +} + +.radio.inline, +.checkbox.inline { + display: inline-block; + padding-top: 5px; + margin-bottom: 0; + vertical-align: middle; +} + +.radio.inline + .radio.inline, +.checkbox.inline + .checkbox.inline { + margin-left: 10px; +} + +.input-mini { + width: 60px; +} + +.input-small { + width: 90px; +} + +.input-medium { + width: 150px; +} + +.input-large { + width: 210px; +} + +.input-xlarge { + width: 270px; +} + +.input-xxlarge { + width: 530px; +} + +input[class*="span"], +select[class*="span"], +textarea[class*="span"], +.uneditable-input[class*="span"], +.row-fluid input[class*="span"], +.row-fluid select[class*="span"], +.row-fluid textarea[class*="span"], +.row-fluid .uneditable-input[class*="span"] { + float: none; + margin-left: 0; +} + +.input-append input[class*="span"], +.input-append .uneditable-input[class*="span"], +.input-prepend input[class*="span"], +.input-prepend .uneditable-input[class*="span"], +.row-fluid input[class*="span"], +.row-fluid select[class*="span"], +.row-fluid textarea[class*="span"], +.row-fluid .uneditable-input[class*="span"], +.row-fluid .input-prepend [class*="span"], +.row-fluid .input-append [class*="span"] { + display: inline-block; +} + +input, +textarea, +.uneditable-input { + margin-left: 0; +} + +.controls-row [class*="span"] + [class*="span"] { + margin-left: 20px; +} + +input.span12, +textarea.span12, +.uneditable-input.span12 { + width: 926px; +} + +input.span11, +textarea.span11, +.uneditable-input.span11 { + width: 846px; +} + +input.span10, +textarea.span10, +.uneditable-input.span10 { + width: 766px; +} + +input.span9, +textarea.span9, +.uneditable-input.span9 { + width: 686px; +} + +input.span8, +textarea.span8, +.uneditable-input.span8 { + width: 606px; +} + +input.span7, +textarea.span7, +.uneditable-input.span7 { + width: 526px; +} + +input.span6, +textarea.span6, +.uneditable-input.span6 { + width: 446px; +} + +input.span5, +textarea.span5, +.uneditable-input.span5 { + width: 366px; +} + +input.span4, +textarea.span4, +.uneditable-input.span4 { + width: 286px; +} + +input.span3, +textarea.span3, +.uneditable-input.span3 { + width: 206px; +} + +input.span2, +textarea.span2, +.uneditable-input.span2 { + width: 126px; +} + +input.span1, +textarea.span1, +.uneditable-input.span1 { + width: 46px; +} + +.controls-row { + *zoom: 1; +} + +.controls-row:before, +.controls-row:after { + display: table; + line-height: 0; + content: ""; +} + +.controls-row:after { + clear: both; +} + +.controls-row [class*="span"], +.row-fluid .controls-row [class*="span"] { + float: left; +} + +.controls-row .checkbox[class*="span"], +.controls-row .radio[class*="span"] { + padding-top: 5px; +} + +input[disabled], +select[disabled], +textarea[disabled], +input[readonly], +select[readonly], +textarea[readonly] { + cursor: not-allowed; + background-color: #eeeeee; +} + +input[type="radio"][disabled], +input[type="checkbox"][disabled], +input[type="radio"][readonly], +input[type="checkbox"][readonly] { + background-color: transparent; +} + +.control-group.warning .control-label, +.control-group.warning .help-block, +.control-group.warning .help-inline { + color: #c09853; +} + +.control-group.warning .checkbox, +.control-group.warning .radio, +.control-group.warning input, +.control-group.warning select, +.control-group.warning textarea { + color: #c09853; +} + +.control-group.warning input, +.control-group.warning select, +.control-group.warning textarea { + border-color: #c09853; + -webkit-box-shadow: inset 0 1px 1px rgba(0, 0, 0, 0.075); + -moz-box-shadow: inset 0 1px 1px rgba(0, 0, 0, 0.075); + box-shadow: inset 0 1px 1px rgba(0, 0, 0, 0.075); +} + +.control-group.warning input:focus, +.control-group.warning select:focus, +.control-group.warning textarea:focus { + border-color: #a47e3c; + -webkit-box-shadow: inset 0 1px 1px rgba(0, 0, 0, 0.075), 0 0 6px #dbc59e; + -moz-box-shadow: inset 0 1px 1px rgba(0, 0, 0, 0.075), 0 0 6px #dbc59e; + box-shadow: inset 0 1px 1px rgba(0, 0, 0, 0.075), 0 0 6px #dbc59e; +} + +.control-group.warning .input-prepend .add-on, +.control-group.warning .input-append .add-on { + color: #c09853; + background-color: #fcf8e3; + border-color: #c09853; +} + +.control-group.error .control-label, +.control-group.error .help-block, +.control-group.error .help-inline { + color: #b94a48; +} + +.control-group.error .checkbox, +.control-group.error .radio, +.control-group.error input, +.control-group.error select, +.control-group.error textarea { + color: #b94a48; +} + +.control-group.error input, +.control-group.error select, +.control-group.error textarea { + border-color: #b94a48; + -webkit-box-shadow: inset 0 1px 1px rgba(0, 0, 0, 0.075); + -moz-box-shadow: inset 0 1px 1px rgba(0, 0, 0, 0.075); + box-shadow: inset 0 1px 1px rgba(0, 0, 0, 0.075); +} + +.control-group.error input:focus, +.control-group.error select:focus, +.control-group.error textarea:focus { + border-color: #953b39; + -webkit-box-shadow: inset 0 1px 1px rgba(0, 0, 0, 0.075), 0 0 6px #d59392; + -moz-box-shadow: inset 0 1px 1px rgba(0, 0, 0, 0.075), 0 0 6px #d59392; + box-shadow: inset 0 1px 1px rgba(0, 0, 0, 0.075), 0 0 6px #d59392; +} + +.control-group.error .input-prepend .add-on, +.control-group.error .input-append .add-on { + color: #b94a48; + background-color: #f2dede; + border-color: #b94a48; +} + +.control-group.success .control-label, +.control-group.success .help-block, +.control-group.success .help-inline { + color: #468847; +} + +.control-group.success .checkbox, +.control-group.success .radio, +.control-group.success input, +.control-group.success select, +.control-group.success textarea { + color: #468847; +} + +.control-group.success input, +.control-group.success select, +.control-group.success textarea { + border-color: #468847; + -webkit-box-shadow: inset 0 1px 1px rgba(0, 0, 0, 0.075); + -moz-box-shadow: inset 0 1px 1px rgba(0, 0, 0, 0.075); + box-shadow: inset 0 1px 1px rgba(0, 0, 0, 0.075); +} + +.control-group.success input:focus, +.control-group.success select:focus, +.control-group.success textarea:focus { + border-color: #356635; + -webkit-box-shadow: inset 0 1px 1px rgba(0, 0, 0, 0.075), 0 0 6px #7aba7b; + -moz-box-shadow: inset 0 1px 1px rgba(0, 0, 0, 0.075), 0 0 6px #7aba7b; + box-shadow: inset 0 1px 1px rgba(0, 0, 0, 0.075), 0 0 6px #7aba7b; +} + +.control-group.success .input-prepend .add-on, +.control-group.success .input-append .add-on { + color: #468847; + background-color: #dff0d8; + border-color: #468847; +} + +.control-group.info .control-label, +.control-group.info .help-block, +.control-group.info .help-inline { + color: #3a87ad; +} + +.control-group.info .checkbox, +.control-group.info .radio, +.control-group.info input, +.control-group.info select, +.control-group.info textarea { + color: #3a87ad; +} + +.control-group.info input, +.control-group.info select, +.control-group.info textarea { + border-color: #3a87ad; + -webkit-box-shadow: inset 0 1px 1px rgba(0, 0, 0, 0.075); + -moz-box-shadow: inset 0 1px 1px rgba(0, 0, 0, 0.075); + box-shadow: inset 0 1px 1px rgba(0, 0, 0, 0.075); +} + +.control-group.info input:focus, +.control-group.info select:focus, +.control-group.info textarea:focus { + border-color: #2d6987; + -webkit-box-shadow: inset 0 1px 1px rgba(0, 0, 0, 0.075), 0 0 6px #7ab5d3; + -moz-box-shadow: inset 0 1px 1px rgba(0, 0, 0, 0.075), 0 0 6px #7ab5d3; + box-shadow: inset 0 1px 1px rgba(0, 0, 0, 0.075), 0 0 6px #7ab5d3; +} + +.control-group.info .input-prepend .add-on, +.control-group.info .input-append .add-on { + color: #3a87ad; + background-color: #d9edf7; + border-color: #3a87ad; +} + +input:focus:invalid, +textarea:focus:invalid, +select:focus:invalid { + color: #b94a48; + border-color: #ee5f5b; +} + +input:focus:invalid:focus, +textarea:focus:invalid:focus, +select:focus:invalid:focus { + border-color: #e9322d; + -webkit-box-shadow: 0 0 6px #f8b9b7; + -moz-box-shadow: 0 0 6px #f8b9b7; + box-shadow: 0 0 6px #f8b9b7; +} + +.form-actions { + padding: 19px 20px 20px; + margin-top: 20px; + margin-bottom: 20px; + background-color: #f5f5f5; + border-top: 1px solid #e5e5e5; + *zoom: 1; +} + +.form-actions:before, +.form-actions:after { + display: table; + line-height: 0; + content: ""; +} + +.form-actions:after { + clear: both; +} + +.help-block, +.help-inline { + color: #595959; +} + +.help-block { + display: block; + margin-bottom: 10px; +} + +.help-inline { + display: inline-block; + *display: inline; + padding-left: 5px; + vertical-align: middle; + *zoom: 1; +} + +.input-append, +.input-prepend { + margin-bottom: 5px; + font-size: 0; + white-space: nowrap; +} + +.input-append input, +.input-prepend input, +.input-append select, +.input-prepend select, +.input-append .uneditable-input, +.input-prepend .uneditable-input, +.input-append .dropdown-menu, +.input-prepend .dropdown-menu { + font-size: 14px; +} + +.input-append input, +.input-prepend input, +.input-append select, +.input-prepend select, +.input-append .uneditable-input, +.input-prepend .uneditable-input { + position: relative; + margin-bottom: 0; + *margin-left: 0; + vertical-align: top; + -webkit-border-radius: 0 4px 4px 0; + -moz-border-radius: 0 4px 4px 0; + border-radius: 0 4px 4px 0; +} + +.input-append input:focus, +.input-prepend input:focus, +.input-append select:focus, +.input-prepend select:focus, +.input-append .uneditable-input:focus, +.input-prepend .uneditable-input:focus { + z-index: 2; +} + +.input-append .add-on, +.input-prepend .add-on { + display: inline-block; + width: auto; + height: 20px; + min-width: 16px; + padding: 4px 5px; + font-size: 14px; + font-weight: normal; + line-height: 20px; + text-align: center; + text-shadow: 0 1px 0 #ffffff; + background-color: #eeeeee; + border: 1px solid #ccc; +} + +.input-append .add-on, +.input-prepend .add-on, +.input-append .btn, +.input-prepend .btn, +.input-append .btn-group > .dropdown-toggle, +.input-prepend .btn-group > .dropdown-toggle { + vertical-align: top; + -webkit-border-radius: 0; + -moz-border-radius: 0; + border-radius: 0; +} + +.input-append .active, +.input-prepend .active { + background-color: #a9dba9; + border-color: #46a546; +} + +.input-prepend .add-on, +.input-prepend .btn { + margin-right: -1px; +} + +.input-prepend .add-on:first-child, +.input-prepend .btn:first-child { + -webkit-border-radius: 4px 0 0 4px; + -moz-border-radius: 4px 0 0 4px; + border-radius: 4px 0 0 4px; +} + +.input-append input, +.input-append select, +.input-append .uneditable-input { + -webkit-border-radius: 4px 0 0 4px; + -moz-border-radius: 4px 0 0 4px; + border-radius: 4px 0 0 4px; +} + +.input-append input + .btn-group .btn:last-child, +.input-append select + .btn-group .btn:last-child, +.input-append .uneditable-input + .btn-group .btn:last-child { + -webkit-border-radius: 0 4px 4px 0; + -moz-border-radius: 0 4px 4px 0; + border-radius: 0 4px 4px 0; +} + +.input-append .add-on, +.input-append .btn, +.input-append .btn-group { + margin-left: -1px; +} + +.input-append .add-on:last-child, +.input-append .btn:last-child, +.input-append .btn-group:last-child > .dropdown-toggle { + -webkit-border-radius: 0 4px 4px 0; + -moz-border-radius: 0 4px 4px 0; + border-radius: 0 4px 4px 0; +} + +.input-prepend.input-append input, +.input-prepend.input-append select, +.input-prepend.input-append .uneditable-input { + -webkit-border-radius: 0; + -moz-border-radius: 0; + border-radius: 0; +} + +.input-prepend.input-append input + .btn-group .btn, +.input-prepend.input-append select + .btn-group .btn, +.input-prepend.input-append .uneditable-input + .btn-group .btn { + -webkit-border-radius: 0 4px 4px 0; + -moz-border-radius: 0 4px 4px 0; + border-radius: 0 4px 4px 0; +} + +.input-prepend.input-append .add-on:first-child, +.input-prepend.input-append .btn:first-child { + margin-right: -1px; + -webkit-border-radius: 4px 0 0 4px; + -moz-border-radius: 4px 0 0 4px; + border-radius: 4px 0 0 4px; +} + +.input-prepend.input-append .add-on:last-child, +.input-prepend.input-append .btn:last-child { + margin-left: -1px; + -webkit-border-radius: 0 4px 4px 0; + -moz-border-radius: 0 4px 4px 0; + border-radius: 0 4px 4px 0; +} + +.input-prepend.input-append .btn-group:first-child { + margin-left: 0; +} + +input.search-query { + padding-right: 14px; + padding-right: 4px \9; + padding-left: 14px; + padding-left: 4px \9; + /* IE7-8 doesn't have border-radius, so don't indent the padding */ + + margin-bottom: 0; + -webkit-border-radius: 15px; + -moz-border-radius: 15px; + border-radius: 15px; +} + +/* Allow for input prepend/append in search forms */ + +.form-search .input-append .search-query, +.form-search .input-prepend .search-query { + -webkit-border-radius: 0; + -moz-border-radius: 0; + border-radius: 0; +} + +.form-search .input-append .search-query { + -webkit-border-radius: 14px 0 0 14px; + -moz-border-radius: 14px 0 0 14px; + border-radius: 14px 0 0 14px; +} + +.form-search .input-append .btn { + -webkit-border-radius: 0 14px 14px 0; + -moz-border-radius: 0 14px 14px 0; + border-radius: 0 14px 14px 0; +} + +.form-search .input-prepend .search-query { + -webkit-border-radius: 0 14px 14px 0; + -moz-border-radius: 0 14px 14px 0; + border-radius: 0 14px 14px 0; +} + +.form-search .input-prepend .btn { + -webkit-border-radius: 14px 0 0 14px; + -moz-border-radius: 14px 0 0 14px; + border-radius: 14px 0 0 14px; +} + +.form-search input, +.form-inline input, +.form-horizontal input, +.form-search textarea, +.form-inline textarea, +.form-horizontal textarea, +.form-search select, +.form-inline select, +.form-horizontal select, +.form-search .help-inline, +.form-inline .help-inline, +.form-horizontal .help-inline, +.form-search .uneditable-input, +.form-inline .uneditable-input, +.form-horizontal .uneditable-input, +.form-search .input-prepend, +.form-inline .input-prepend, +.form-horizontal .input-prepend, +.form-search .input-append, +.form-inline .input-append, +.form-horizontal .input-append { + display: inline-block; + *display: inline; + margin-bottom: 0; + vertical-align: middle; + *zoom: 1; +} + +.form-search .hide, +.form-inline .hide, +.form-horizontal .hide { + display: none; +} + +.form-search label, +.form-inline label, +.form-search .btn-group, +.form-inline .btn-group { + display: inline-block; +} + +.form-search .input-append, +.form-inline .input-append, +.form-search .input-prepend, +.form-inline .input-prepend { + margin-bottom: 0; +} + +.form-search .radio, +.form-search .checkbox, +.form-inline .radio, +.form-inline .checkbox { + padding-left: 0; + margin-bottom: 0; + vertical-align: middle; +} + +.form-search .radio input[type="radio"], +.form-search .checkbox input[type="checkbox"], +.form-inline .radio input[type="radio"], +.form-inline .checkbox input[type="checkbox"] { + float: left; + margin-right: 3px; + margin-left: 0; +} + +.control-group { + margin-bottom: 10px; +} + +legend + .control-group { + margin-top: 20px; + -webkit-margin-top-collapse: separate; +} + +.form-horizontal .control-group { + margin-bottom: 20px; + *zoom: 1; +} + +.form-horizontal .control-group:before, +.form-horizontal .control-group:after { + display: table; + line-height: 0; + content: ""; +} + +.form-horizontal .control-group:after { + clear: both; +} + +.form-horizontal .control-label { + float: left; + width: 160px; + padding-top: 5px; + text-align: right; +} + +.form-horizontal .controls { + *display: inline-block; + *padding-left: 20px; + margin-left: 180px; + *margin-left: 0; +} + +.form-horizontal .controls:first-child { + *padding-left: 180px; +} + +.form-horizontal .help-block { + margin-bottom: 0; +} + +.form-horizontal input + .help-block, +.form-horizontal select + .help-block, +.form-horizontal textarea + .help-block, +.form-horizontal .uneditable-input + .help-block, +.form-horizontal .input-prepend + .help-block, +.form-horizontal .input-append + .help-block { + margin-top: 10px; +} + +.form-horizontal .form-actions { + padding-left: 180px; +} + +table { + max-width: 100%; + background-color: transparent; + border-collapse: collapse; + border-spacing: 0; +} + +.table { + width: 100%; + margin-bottom: 20px; +} + +.table th, +.table td { + padding: 8px; + line-height: 20px; + text-align: left; + vertical-align: top; + border-top: 1px solid #dddddd; +} + +.table th { + font-weight: bold; +} + +.table thead th { + vertical-align: bottom; +} + +.table caption + thead tr:first-child th, +.table caption + thead tr:first-child td, +.table colgroup + thead tr:first-child th, +.table colgroup + thead tr:first-child td, +.table thead:first-child tr:first-child th, +.table thead:first-child tr:first-child td { + border-top: 0; +} + +.table tbody + tbody { + border-top: 2px solid #dddddd; +} + +.table .table { + background-color: #ffffff; +} + +.table-condensed th, +.table-condensed td { + padding: 4px 5px; +} + +.table-bordered { + border: 1px solid #dddddd; + border-collapse: separate; + *border-collapse: collapse; + border-left: 0; + -webkit-border-radius: 4px; + -moz-border-radius: 4px; + border-radius: 4px; +} + +.table-bordered th, +.table-bordered td { + border-left: 1px solid #dddddd; +} + +.table-bordered caption + thead tr:first-child th, +.table-bordered caption + tbody tr:first-child th, +.table-bordered caption + tbody tr:first-child td, +.table-bordered colgroup + thead tr:first-child th, +.table-bordered colgroup + tbody tr:first-child th, +.table-bordered colgroup + tbody tr:first-child td, +.table-bordered thead:first-child tr:first-child th, +.table-bordered tbody:first-child tr:first-child th, +.table-bordered tbody:first-child tr:first-child td { + border-top: 0; +} + +.table-bordered thead:first-child tr:first-child > th:first-child, +.table-bordered tbody:first-child tr:first-child > td:first-child { + -webkit-border-top-left-radius: 4px; + border-top-left-radius: 4px; + -moz-border-radius-topleft: 4px; +} + +.table-bordered thead:first-child tr:first-child > th:last-child, +.table-bordered tbody:first-child tr:first-child > td:last-child { + -webkit-border-top-right-radius: 4px; + border-top-right-radius: 4px; + -moz-border-radius-topright: 4px; +} + +.table-bordered thead:last-child tr:last-child > th:first-child, +.table-bordered tbody:last-child tr:last-child > td:first-child, +.table-bordered tfoot:last-child tr:last-child > td:first-child { + -webkit-border-bottom-left-radius: 4px; + border-bottom-left-radius: 4px; + -moz-border-radius-bottomleft: 4px; +} + +.table-bordered thead:last-child tr:last-child > th:last-child, +.table-bordered tbody:last-child tr:last-child > td:last-child, +.table-bordered tfoot:last-child tr:last-child > td:last-child { + -webkit-border-bottom-right-radius: 4px; + border-bottom-right-radius: 4px; + -moz-border-radius-bottomright: 4px; +} + +.table-bordered tfoot + tbody:last-child tr:last-child td:first-child { + -webkit-border-bottom-left-radius: 0; + border-bottom-left-radius: 0; + -moz-border-radius-bottomleft: 0; +} + +.table-bordered tfoot + tbody:last-child tr:last-child td:last-child { + -webkit-border-bottom-right-radius: 0; + border-bottom-right-radius: 0; + -moz-border-radius-bottomright: 0; +} + +.table-bordered caption + thead tr:first-child th:first-child, +.table-bordered caption + tbody tr:first-child td:first-child, +.table-bordered colgroup + thead tr:first-child th:first-child, +.table-bordered colgroup + tbody tr:first-child td:first-child { + -webkit-border-top-left-radius: 4px; + border-top-left-radius: 4px; + -moz-border-radius-topleft: 4px; +} + +.table-bordered caption + thead tr:first-child th:last-child, +.table-bordered caption + tbody tr:first-child td:last-child, +.table-bordered colgroup + thead tr:first-child th:last-child, +.table-bordered colgroup + tbody tr:first-child td:last-child { + -webkit-border-top-right-radius: 4px; + border-top-right-radius: 4px; + -moz-border-radius-topright: 4px; +} + +.table-striped tbody > tr:nth-child(odd) > td, +.table-striped tbody > tr:nth-child(odd) > th { + background-color: #f9f9f9; +} + +.table-hover tbody tr:hover td, +.table-hover tbody tr:hover th { + background-color: #f5f5f5; +} + +table td[class*="span"], +table th[class*="span"], +.row-fluid table td[class*="span"], +.row-fluid table th[class*="span"] { + display: table-cell; + float: none; + margin-left: 0; +} + +.table td.span1, +.table th.span1 { + float: none; + width: 44px; + margin-left: 0; +} + +.table td.span2, +.table th.span2 { + float: none; + width: 124px; + margin-left: 0; +} + +.table td.span3, +.table th.span3 { + float: none; + width: 204px; + margin-left: 0; +} + +.table td.span4, +.table th.span4 { + float: none; + width: 284px; + margin-left: 0; +} + +.table td.span5, +.table th.span5 { + float: none; + width: 364px; + margin-left: 0; +} + +.table td.span6, +.table th.span6 { + float: none; + width: 444px; + margin-left: 0; +} + +.table td.span7, +.table th.span7 { + float: none; + width: 524px; + margin-left: 0; +} + +.table td.span8, +.table th.span8 { + float: none; + width: 604px; + margin-left: 0; +} + +.table td.span9, +.table th.span9 { + float: none; + width: 684px; + margin-left: 0; +} + +.table td.span10, +.table th.span10 { + float: none; + width: 764px; + margin-left: 0; +} + +.table td.span11, +.table th.span11 { + float: none; + width: 844px; + margin-left: 0; +} + +.table td.span12, +.table th.span12 { + float: none; + width: 924px; + margin-left: 0; +} + +.table tbody tr.success td { + background-color: #dff0d8; +} + +.table tbody tr.error td { + background-color: #f2dede; +} + +.table tbody tr.warning td { + background-color: #fcf8e3; +} + +.table tbody tr.info td { + background-color: #d9edf7; +} + +.table-hover tbody tr.success:hover td { + background-color: #d0e9c6; +} + +.table-hover tbody tr.error:hover td { + background-color: #ebcccc; +} + +.table-hover tbody tr.warning:hover td { + background-color: #faf2cc; +} + +.table-hover tbody tr.info:hover td { + background-color: #c4e3f3; +} + +[class^="icon-"], +[class*=" icon-"] { + display: inline-block; + width: 14px; + height: 14px; + margin-top: 1px; + *margin-right: .3em; + line-height: 14px; + vertical-align: text-top; + background-image: url("../img/glyphicons-halflings.png"); + background-position: 14px 14px; + background-repeat: no-repeat; +} + +/* White icons with optional class, or on hover/active states of certain elements */ + +.icon-white, +.nav-pills > .active > a > [class^="icon-"], +.nav-pills > .active > a > [class*=" icon-"], +.nav-list > .active > a > [class^="icon-"], +.nav-list > .active > a > [class*=" icon-"], +.navbar-inverse .nav > .active > a > [class^="icon-"], +.navbar-inverse .nav > .active > a > [class*=" icon-"], +.dropdown-menu > li > a:hover > [class^="icon-"], +.dropdown-menu > li > a:hover > [class*=" icon-"], +.dropdown-menu > .active > a > [class^="icon-"], +.dropdown-menu > .active > a > [class*=" icon-"], +.dropdown-submenu:hover > a > [class^="icon-"], +.dropdown-submenu:hover > a > [class*=" icon-"] { + background-image: url("../img/glyphicons-halflings-white.png"); +} + +.icon-glass { + background-position: 0 0; +} + +.icon-music { + background-position: -24px 0; +} + +.icon-search { + background-position: -48px 0; +} + +.icon-envelope { + background-position: -72px 0; +} + +.icon-heart { + background-position: -96px 0; +} + +.icon-star { + background-position: -120px 0; +} + +.icon-star-empty { + background-position: -144px 0; +} + +.icon-user { + background-position: -168px 0; +} + +.icon-film { + background-position: -192px 0; +} + +.icon-th-large { + background-position: -216px 0; +} + +.icon-th { + background-position: -240px 0; +} + +.icon-th-list { + background-position: -264px 0; +} + +.icon-ok { + background-position: -288px 0; +} + +.icon-remove { + background-position: -312px 0; +} + +.icon-zoom-in { + background-position: -336px 0; +} + +.icon-zoom-out { + background-position: -360px 0; +} + +.icon-off { + background-position: -384px 0; +} + +.icon-signal { + background-position: -408px 0; +} + +.icon-cog { + background-position: -432px 0; +} + +.icon-trash { + background-position: -456px 0; +} + +.icon-home { + background-position: 0 -24px; +} + +.icon-file { + background-position: -24px -24px; +} + +.icon-time { + background-position: -48px -24px; +} + +.icon-road { + background-position: -72px -24px; +} + +.icon-download-alt { + background-position: -96px -24px; +} + +.icon-download { + background-position: -120px -24px; +} + +.icon-upload { + background-position: -144px -24px; +} + +.icon-inbox { + background-position: -168px -24px; +} + +.icon-play-circle { + background-position: -192px -24px; +} + +.icon-repeat { + background-position: -216px -24px; +} + +.icon-refresh { + background-position: -240px -24px; +} + +.icon-list-alt { + background-position: -264px -24px; +} + +.icon-lock { + background-position: -287px -24px; +} + +.icon-flag { + background-position: -312px -24px; +} + +.icon-headphones { + background-position: -336px -24px; +} + +.icon-volume-off { + background-position: -360px -24px; +} + +.icon-volume-down { + background-position: -384px -24px; +} + +.icon-volume-up { + background-position: -408px -24px; +} + +.icon-qrcode { + background-position: -432px -24px; +} + +.icon-barcode { + background-position: -456px -24px; +} + +.icon-tag { + background-position: 0 -48px; +} + +.icon-tags { + background-position: -25px -48px; +} + +.icon-book { + background-position: -48px -48px; +} + +.icon-bookmark { + background-position: -72px -48px; +} + +.icon-print { + background-position: -96px -48px; +} + +.icon-camera { + background-position: -120px -48px; +} + +.icon-font { + background-position: -144px -48px; +} + +.icon-bold { + background-position: -167px -48px; +} + +.icon-italic { + background-position: -192px -48px; +} + +.icon-text-height { + background-position: -216px -48px; +} + +.icon-text-width { + background-position: -240px -48px; +} + +.icon-align-left { + background-position: -264px -48px; +} + +.icon-align-center { + background-position: -288px -48px; +} + +.icon-align-right { + background-position: -312px -48px; +} + +.icon-align-justify { + background-position: -336px -48px; +} + +.icon-list { + background-position: -360px -48px; +} + +.icon-indent-left { + background-position: -384px -48px; +} + +.icon-indent-right { + background-position: -408px -48px; +} + +.icon-facetime-video { + background-position: -432px -48px; +} + +.icon-picture { + background-position: -456px -48px; +} + +.icon-pencil { + background-position: 0 -72px; +} + +.icon-map-marker { + background-position: -24px -72px; +} + +.icon-adjust { + background-position: -48px -72px; +} + +.icon-tint { + background-position: -72px -72px; +} + +.icon-edit { + background-position: -96px -72px; +} + +.icon-share { + background-position: -120px -72px; +} + +.icon-check { + background-position: -144px -72px; +} + +.icon-move { + background-position: -168px -72px; +} + +.icon-step-backward { + background-position: -192px -72px; +} + +.icon-fast-backward { + background-position: -216px -72px; +} + +.icon-backward { + background-position: -240px -72px; +} + +.icon-play { + background-position: -264px -72px; +} + +.icon-pause { + background-position: -288px -72px; +} + +.icon-stop { + background-position: -312px -72px; +} + +.icon-forward { + background-position: -336px -72px; +} + +.icon-fast-forward { + background-position: -360px -72px; +} + +.icon-step-forward { + background-position: -384px -72px; +} + +.icon-eject { + background-position: -408px -72px; +} + +.icon-chevron-left { + background-position: -432px -72px; +} + +.icon-chevron-right { + background-position: -456px -72px; +} + +.icon-plus-sign { + background-position: 0 -96px; +} + +.icon-minus-sign { + background-position: -24px -96px; +} + +.icon-remove-sign { + background-position: -48px -96px; +} + +.icon-ok-sign { + background-position: -72px -96px; +} + +.icon-question-sign { + background-position: -96px -96px; +} + +.icon-info-sign { + background-position: -120px -96px; +} + +.icon-screenshot { + background-position: -144px -96px; +} + +.icon-remove-circle { + background-position: -168px -96px; +} + +.icon-ok-circle { + background-position: -192px -96px; +} + +.icon-ban-circle { + background-position: -216px -96px; +} + +.icon-arrow-left { + background-position: -240px -96px; +} + +.icon-arrow-right { + background-position: -264px -96px; +} + +.icon-arrow-up { + background-position: -289px -96px; +} + +.icon-arrow-down { + background-position: -312px -96px; +} + +.icon-share-alt { + background-position: -336px -96px; +} + +.icon-resize-full { + background-position: -360px -96px; +} + +.icon-resize-small { + background-position: -384px -96px; +} + +.icon-plus { + background-position: -408px -96px; +} + +.icon-minus { + background-position: -433px -96px; +} + +.icon-asterisk { + background-position: -456px -96px; +} + +.icon-exclamation-sign { + background-position: 0 -120px; +} + +.icon-gift { + background-position: -24px -120px; +} + +.icon-leaf { + background-position: -48px -120px; +} + +.icon-fire { + background-position: -72px -120px; +} + +.icon-eye-open { + background-position: -96px -120px; +} + +.icon-eye-close { + background-position: -120px -120px; +} + +.icon-warning-sign { + background-position: -144px -120px; +} + +.icon-plane { + background-position: -168px -120px; +} + +.icon-calendar { + background-position: -192px -120px; +} + +.icon-random { + width: 16px; + background-position: -216px -120px; +} + +.icon-comment { + background-position: -240px -120px; +} + +.icon-magnet { + background-position: -264px -120px; +} + +.icon-chevron-up { + background-position: -288px -120px; +} + +.icon-chevron-down { + background-position: -313px -119px; +} + +.icon-retweet { + background-position: -336px -120px; +} + +.icon-shopping-cart { + background-position: -360px -120px; +} + +.icon-folder-close { + background-position: -384px -120px; +} + +.icon-folder-open { + width: 16px; + background-position: -408px -120px; +} + +.icon-resize-vertical { + background-position: -432px -119px; +} + +.icon-resize-horizontal { + background-position: -456px -118px; +} + +.icon-hdd { + background-position: 0 -144px; +} + +.icon-bullhorn { + background-position: -24px -144px; +} + +.icon-bell { + background-position: -48px -144px; +} + +.icon-certificate { + background-position: -72px -144px; +} + +.icon-thumbs-up { + background-position: -96px -144px; +} + +.icon-thumbs-down { + background-position: -120px -144px; +} + +.icon-hand-right { + background-position: -144px -144px; +} + +.icon-hand-left { + background-position: -168px -144px; +} + +.icon-hand-up { + background-position: -192px -144px; +} + +.icon-hand-down { + background-position: -216px -144px; +} + +.icon-circle-arrow-right { + background-position: -240px -144px; +} + +.icon-circle-arrow-left { + background-position: -264px -144px; +} + +.icon-circle-arrow-up { + background-position: -288px -144px; +} + +.icon-circle-arrow-down { + background-position: -312px -144px; +} + +.icon-globe { + background-position: -336px -144px; +} + +.icon-wrench { + background-position: -360px -144px; +} + +.icon-tasks { + background-position: -384px -144px; +} + +.icon-filter { + background-position: -408px -144px; +} + +.icon-briefcase { + background-position: -432px -144px; +} + +.icon-fullscreen { + background-position: -456px -144px; +} + +.dropup, +.dropdown { + position: relative; +} + +.dropdown-toggle { + *margin-bottom: -3px; +} + +.dropdown-toggle:active, +.open .dropdown-toggle { + outline: 0; +} + +.caret { + display: inline-block; + width: 0; + height: 0; + vertical-align: top; + border-top: 4px solid #000000; + border-right: 4px solid transparent; + border-left: 4px solid transparent; + content: ""; +} + +.dropdown .caret { + margin-top: 8px; + margin-left: 2px; +} + +.dropdown-menu { + position: absolute; + top: 100%; + left: 0; + z-index: 1000; + display: none; + float: left; + min-width: 160px; + padding: 5px 0; + margin: 2px 0 0; + list-style: none; + background-color: #ffffff; + border: 1px solid #ccc; + border: 1px solid rgba(0, 0, 0, 0.2); + *border-right-width: 2px; + *border-bottom-width: 2px; + -webkit-border-radius: 6px; + -moz-border-radius: 6px; + border-radius: 6px; + -webkit-box-shadow: 0 5px 10px rgba(0, 0, 0, 0.2); + -moz-box-shadow: 0 5px 10px rgba(0, 0, 0, 0.2); + box-shadow: 0 5px 10px rgba(0, 0, 0, 0.2); + -webkit-background-clip: padding-box; + -moz-background-clip: padding; + background-clip: padding-box; +} + +.dropdown-menu.pull-right { + right: 0; + left: auto; +} + +.dropdown-menu .divider { + *width: 100%; + height: 1px; + margin: 9px 1px; + *margin: -5px 0 5px; + overflow: hidden; + background-color: #e5e5e5; + border-bottom: 1px solid #ffffff; +} + +.dropdown-menu li > a { + display: block; + padding: 3px 20px; + clear: both; + font-weight: normal; + line-height: 20px; + color: #333333; + white-space: nowrap; +} + +.dropdown-menu li > a:hover, +.dropdown-menu li > a:focus, +.dropdown-submenu:hover > a { + color: #ffffff; + text-decoration: none; + background-color: #0081c2; + background-image: -moz-linear-gradient(top, #0088cc, #0077b3); + background-image: -webkit-gradient(linear, 0 0, 0 100%, from(#0088cc), to(#0077b3)); + background-image: -webkit-linear-gradient(top, #0088cc, #0077b3); + background-image: -o-linear-gradient(top, #0088cc, #0077b3); + background-image: linear-gradient(to bottom, #0088cc, #0077b3); + background-repeat: repeat-x; + filter: progid:DXImageTransform.Microsoft.gradient(startColorstr='#ff0088cc', endColorstr='#ff0077b3', GradientType=0); +} + +.dropdown-menu .active > a, +.dropdown-menu .active > a:hover { + color: #ffffff; + text-decoration: none; + background-color: #0081c2; + background-image: -moz-linear-gradient(top, #0088cc, #0077b3); + background-image: -webkit-gradient(linear, 0 0, 0 100%, from(#0088cc), to(#0077b3)); + background-image: -webkit-linear-gradient(top, #0088cc, #0077b3); + background-image: -o-linear-gradient(top, #0088cc, #0077b3); + background-image: linear-gradient(to bottom, #0088cc, #0077b3); + background-repeat: repeat-x; + outline: 0; + filter: progid:DXImageTransform.Microsoft.gradient(startColorstr='#ff0088cc', endColorstr='#ff0077b3', GradientType=0); +} + +.dropdown-menu .disabled > a, +.dropdown-menu .disabled > a:hover { + color: #999999; +} + +.dropdown-menu .disabled > a:hover { + text-decoration: none; + cursor: default; + background-color: transparent; + background-image: none; + filter: progid:DXImageTransform.Microsoft.gradient(enabled=false); +} + +.open { + *z-index: 1000; +} + +.open > .dropdown-menu { + display: block; +} + +.pull-right > .dropdown-menu { + right: 0; + left: auto; +} + +.dropup .caret, +.navbar-fixed-bottom .dropdown .caret { + border-top: 0; + border-bottom: 4px solid #000000; + content: ""; +} + +.dropup .dropdown-menu, +.navbar-fixed-bottom .dropdown .dropdown-menu { + top: auto; + bottom: 100%; + margin-bottom: 1px; +} + +.dropdown-submenu { + position: relative; +} + +.dropdown-submenu > .dropdown-menu { + top: 0; + left: 100%; + margin-top: -6px; + margin-left: -1px; + -webkit-border-radius: 0 6px 6px 6px; + -moz-border-radius: 0 6px 6px 6px; + border-radius: 0 6px 6px 6px; +} + +.dropdown-submenu:hover > .dropdown-menu { + display: block; +} + +.dropup .dropdown-submenu > .dropdown-menu { + top: auto; + bottom: 0; + margin-top: 0; + margin-bottom: -2px; + -webkit-border-radius: 5px 5px 5px 0; + -moz-border-radius: 5px 5px 5px 0; + border-radius: 5px 5px 5px 0; +} + +.dropdown-submenu > a:after { + display: block; + float: right; + width: 0; + height: 0; + margin-top: 5px; + margin-right: -10px; + border-color: transparent; + border-left-color: #cccccc; + border-style: solid; + border-width: 5px 0 5px 5px; + content: " "; +} + +.dropdown-submenu:hover > a:after { + border-left-color: #ffffff; +} + +.dropdown-submenu.pull-left { + float: none; +} + +.dropdown-submenu.pull-left > .dropdown-menu { + left: -100%; + margin-left: 10px; + -webkit-border-radius: 6px 0 6px 6px; + -moz-border-radius: 6px 0 6px 6px; + border-radius: 6px 0 6px 6px; +} + +.dropdown .dropdown-menu .nav-header { + padding-right: 20px; + padding-left: 20px; +} + +.typeahead { + z-index: 1051; + margin-top: 2px; + -webkit-border-radius: 4px; + -moz-border-radius: 4px; + border-radius: 4px; +} + +.well { + min-height: 20px; + padding: 19px; + margin-bottom: 20px; + background-color: #f5f5f5; + border: 1px solid #e3e3e3; + -webkit-border-radius: 4px; + -moz-border-radius: 4px; + border-radius: 4px; + -webkit-box-shadow: inset 0 1px 1px rgba(0, 0, 0, 0.05); + -moz-box-shadow: inset 0 1px 1px rgba(0, 0, 0, 0.05); + box-shadow: inset 0 1px 1px rgba(0, 0, 0, 0.05); +} + +.well blockquote { + border-color: #ddd; + border-color: rgba(0, 0, 0, 0.15); +} + +.well-large { + padding: 24px; + -webkit-border-radius: 6px; + -moz-border-radius: 6px; + border-radius: 6px; +} + +.well-small { + padding: 9px; + -webkit-border-radius: 3px; + -moz-border-radius: 3px; + border-radius: 3px; +} + +.fade { + opacity: 0; + -webkit-transition: opacity 0.15s linear; + -moz-transition: opacity 0.15s linear; + -o-transition: opacity 0.15s linear; + transition: opacity 0.15s linear; +} + +.fade.in { + opacity: 1; +} + +.collapse { + position: relative; + height: 0; + overflow: hidden; + -webkit-transition: height 0.35s ease; + -moz-transition: height 0.35s ease; + -o-transition: height 0.35s ease; + transition: height 0.35s ease; +} + +.collapse.in { + height: auto; +} + +.close { + float: right; + font-size: 20px; + font-weight: bold; + line-height: 20px; + color: #000000; + text-shadow: 0 1px 0 #ffffff; + opacity: 0.2; + filter: alpha(opacity=20); +} + +.close:hover { + color: #000000; + text-decoration: none; + cursor: pointer; + opacity: 0.4; + filter: alpha(opacity=40); +} + +button.close { + padding: 0; + cursor: pointer; + background: transparent; + border: 0; + -webkit-appearance: none; +} + +.btn { + display: inline-block; + *display: inline; + padding: 4px 12px; + margin-bottom: 0; + *margin-left: .3em; + font-size: 14px; + line-height: 20px; + color: #333333; + text-align: center; + text-shadow: 0 1px 1px rgba(255, 255, 255, 0.75); + vertical-align: middle; + cursor: pointer; + background-color: #f5f5f5; + *background-color: #e6e6e6; + background-image: -moz-linear-gradient(top, #ffffff, #e6e6e6); + background-image: -webkit-gradient(linear, 0 0, 0 100%, from(#ffffff), to(#e6e6e6)); + background-image: -webkit-linear-gradient(top, #ffffff, #e6e6e6); + background-image: -o-linear-gradient(top, #ffffff, #e6e6e6); + background-image: linear-gradient(to bottom, #ffffff, #e6e6e6); + background-repeat: repeat-x; + border: 1px solid #bbbbbb; + *border: 0; + border-color: #e6e6e6 #e6e6e6 #bfbfbf; + border-color: rgba(0, 0, 0, 0.1) rgba(0, 0, 0, 0.1) rgba(0, 0, 0, 0.25); + border-bottom-color: #a2a2a2; + -webkit-border-radius: 4px; + -moz-border-radius: 4px; + border-radius: 4px; + filter: progid:DXImageTransform.Microsoft.gradient(startColorstr='#ffffffff', endColorstr='#ffe6e6e6', GradientType=0); + filter: progid:DXImageTransform.Microsoft.gradient(enabled=false); + *zoom: 1; + -webkit-box-shadow: inset 0 1px 0 rgba(255, 255, 255, 0.2), 0 1px 2px rgba(0, 0, 0, 0.05); + -moz-box-shadow: inset 0 1px 0 rgba(255, 255, 255, 0.2), 0 1px 2px rgba(0, 0, 0, 0.05); + box-shadow: inset 0 1px 0 rgba(255, 255, 255, 0.2), 0 1px 2px rgba(0, 0, 0, 0.05); +} + +.btn:hover, +.btn:active, +.btn.active, +.btn.disabled, +.btn[disabled] { + color: #333333; + background-color: #e6e6e6; + *background-color: #d9d9d9; +} + +.btn:active, +.btn.active { + background-color: #cccccc \9; +} + +.btn:first-child { + *margin-left: 0; +} + +.btn:hover { + color: #333333; + text-decoration: none; + background-position: 0 -15px; + -webkit-transition: background-position 0.1s linear; + -moz-transition: background-position 0.1s linear; + -o-transition: background-position 0.1s linear; + transition: background-position 0.1s linear; +} + +.btn:focus { + outline: thin dotted #333; + outline: 5px auto -webkit-focus-ring-color; + outline-offset: -2px; +} + +.btn.active, +.btn:active { + background-image: none; + outline: 0; + -webkit-box-shadow: inset 0 2px 4px rgba(0, 0, 0, 0.15), 0 1px 2px rgba(0, 0, 0, 0.05); + -moz-box-shadow: inset 0 2px 4px rgba(0, 0, 0, 0.15), 0 1px 2px rgba(0, 0, 0, 0.05); + box-shadow: inset 0 2px 4px rgba(0, 0, 0, 0.15), 0 1px 2px rgba(0, 0, 0, 0.05); +} + +.btn.disabled, +.btn[disabled] { + cursor: default; + background-image: none; + opacity: 0.65; + filter: alpha(opacity=65); + -webkit-box-shadow: none; + -moz-box-shadow: none; + box-shadow: none; +} + +.btn-large { + padding: 11px 19px; + font-size: 17.5px; + -webkit-border-radius: 6px; + -moz-border-radius: 6px; + border-radius: 6px; +} + +.btn-large [class^="icon-"], +.btn-large [class*=" icon-"] { + margin-top: 4px; +} + +.btn-small { + padding: 2px 10px; + font-size: 11.9px; + -webkit-border-radius: 3px; + -moz-border-radius: 3px; + border-radius: 3px; +} + +.btn-small [class^="icon-"], +.btn-small [class*=" icon-"] { + margin-top: 0; +} + +.btn-mini [class^="icon-"], +.btn-mini [class*=" icon-"] { + margin-top: -1px; +} + +.btn-mini { + padding: 0 6px; + font-size: 10.5px; + -webkit-border-radius: 3px; + -moz-border-radius: 3px; + border-radius: 3px; +} + +.btn-block { + display: block; + width: 100%; + padding-right: 0; + padding-left: 0; + -webkit-box-sizing: border-box; + -moz-box-sizing: border-box; + box-sizing: border-box; +} + +.btn-block + .btn-block { + margin-top: 5px; +} + +input[type="submit"].btn-block, +input[type="reset"].btn-block, +input[type="button"].btn-block { + width: 100%; +} + +.btn-primary.active, +.btn-warning.active, +.btn-danger.active, +.btn-success.active, +.btn-info.active, +.btn-inverse.active { + color: rgba(255, 255, 255, 0.75); +} + +.btn { + border-color: #c5c5c5; + border-color: rgba(0, 0, 0, 0.15) rgba(0, 0, 0, 0.15) rgba(0, 0, 0, 0.25); +} + +.btn-primary { + color: #ffffff; + text-shadow: 0 -1px 0 rgba(0, 0, 0, 0.25); + background-color: #006dcc; + *background-color: #0044cc; + background-image: -moz-linear-gradient(top, #0088cc, #0044cc); + background-image: -webkit-gradient(linear, 0 0, 0 100%, from(#0088cc), to(#0044cc)); + background-image: -webkit-linear-gradient(top, #0088cc, #0044cc); + background-image: -o-linear-gradient(top, #0088cc, #0044cc); + background-image: linear-gradient(to bottom, #0088cc, #0044cc); + background-repeat: repeat-x; + border-color: #0044cc #0044cc #002a80; + border-color: rgba(0, 0, 0, 0.1) rgba(0, 0, 0, 0.1) rgba(0, 0, 0, 0.25); + filter: progid:DXImageTransform.Microsoft.gradient(startColorstr='#ff0088cc', endColorstr='#ff0044cc', GradientType=0); + filter: progid:DXImageTransform.Microsoft.gradient(enabled=false); +} + +.btn-primary:hover, +.btn-primary:active, +.btn-primary.active, +.btn-primary.disabled, +.btn-primary[disabled] { + color: #ffffff; + background-color: #0044cc; + *background-color: #003bb3; +} + +.btn-primary:active, +.btn-primary.active { + background-color: #003399 \9; +} + +.btn-warning { + color: #ffffff; + text-shadow: 0 -1px 0 rgba(0, 0, 0, 0.25); + background-color: #faa732; + *background-color: #f89406; + background-image: -moz-linear-gradient(top, #fbb450, #f89406); + background-image: -webkit-gradient(linear, 0 0, 0 100%, from(#fbb450), to(#f89406)); + background-image: -webkit-linear-gradient(top, #fbb450, #f89406); + background-image: -o-linear-gradient(top, #fbb450, #f89406); + background-image: linear-gradient(to bottom, #fbb450, #f89406); + background-repeat: repeat-x; + border-color: #f89406 #f89406 #ad6704; + border-color: rgba(0, 0, 0, 0.1) rgba(0, 0, 0, 0.1) rgba(0, 0, 0, 0.25); + filter: progid:DXImageTransform.Microsoft.gradient(startColorstr='#fffbb450', endColorstr='#fff89406', GradientType=0); + filter: progid:DXImageTransform.Microsoft.gradient(enabled=false); +} + +.btn-warning:hover, +.btn-warning:active, +.btn-warning.active, +.btn-warning.disabled, +.btn-warning[disabled] { + color: #ffffff; + background-color: #f89406; + *background-color: #df8505; +} + +.btn-warning:active, +.btn-warning.active { + background-color: #c67605 \9; +} + +.btn-danger { + color: #ffffff; + text-shadow: 0 -1px 0 rgba(0, 0, 0, 0.25); + background-color: #da4f49; + *background-color: #bd362f; + background-image: -moz-linear-gradient(top, #ee5f5b, #bd362f); + background-image: -webkit-gradient(linear, 0 0, 0 100%, from(#ee5f5b), to(#bd362f)); + background-image: -webkit-linear-gradient(top, #ee5f5b, #bd362f); + background-image: -o-linear-gradient(top, #ee5f5b, #bd362f); + background-image: linear-gradient(to bottom, #ee5f5b, #bd362f); + background-repeat: repeat-x; + border-color: #bd362f #bd362f #802420; + border-color: rgba(0, 0, 0, 0.1) rgba(0, 0, 0, 0.1) rgba(0, 0, 0, 0.25); + filter: progid:DXImageTransform.Microsoft.gradient(startColorstr='#ffee5f5b', endColorstr='#ffbd362f', GradientType=0); + filter: progid:DXImageTransform.Microsoft.gradient(enabled=false); +} + +.btn-danger:hover, +.btn-danger:active, +.btn-danger.active, +.btn-danger.disabled, +.btn-danger[disabled] { + color: #ffffff; + background-color: #bd362f; + *background-color: #a9302a; +} + +.btn-danger:active, +.btn-danger.active { + background-color: #942a25 \9; +} + +.btn-success { + color: #ffffff; + text-shadow: 0 -1px 0 rgba(0, 0, 0, 0.25); + background-color: #5bb75b; + *background-color: #51a351; + background-image: -moz-linear-gradient(top, #62c462, #51a351); + background-image: -webkit-gradient(linear, 0 0, 0 100%, from(#62c462), to(#51a351)); + background-image: -webkit-linear-gradient(top, #62c462, #51a351); + background-image: -o-linear-gradient(top, #62c462, #51a351); + background-image: linear-gradient(to bottom, #62c462, #51a351); + background-repeat: repeat-x; + border-color: #51a351 #51a351 #387038; + border-color: rgba(0, 0, 0, 0.1) rgba(0, 0, 0, 0.1) rgba(0, 0, 0, 0.25); + filter: progid:DXImageTransform.Microsoft.gradient(startColorstr='#ff62c462', endColorstr='#ff51a351', GradientType=0); + filter: progid:DXImageTransform.Microsoft.gradient(enabled=false); +} + +.btn-success:hover, +.btn-success:active, +.btn-success.active, +.btn-success.disabled, +.btn-success[disabled] { + color: #ffffff; + background-color: #51a351; + *background-color: #499249; +} + +.btn-success:active, +.btn-success.active { + background-color: #408140 \9; +} + +.btn-info { + color: #ffffff; + text-shadow: 0 -1px 0 rgba(0, 0, 0, 0.25); + background-color: #49afcd; + *background-color: #2f96b4; + background-image: -moz-linear-gradient(top, #5bc0de, #2f96b4); + background-image: -webkit-gradient(linear, 0 0, 0 100%, from(#5bc0de), to(#2f96b4)); + background-image: -webkit-linear-gradient(top, #5bc0de, #2f96b4); + background-image: -o-linear-gradient(top, #5bc0de, #2f96b4); + background-image: linear-gradient(to bottom, #5bc0de, #2f96b4); + background-repeat: repeat-x; + border-color: #2f96b4 #2f96b4 #1f6377; + border-color: rgba(0, 0, 0, 0.1) rgba(0, 0, 0, 0.1) rgba(0, 0, 0, 0.25); + filter: progid:DXImageTransform.Microsoft.gradient(startColorstr='#ff5bc0de', endColorstr='#ff2f96b4', GradientType=0); + filter: progid:DXImageTransform.Microsoft.gradient(enabled=false); +} + +.btn-info:hover, +.btn-info:active, +.btn-info.active, +.btn-info.disabled, +.btn-info[disabled] { + color: #ffffff; + background-color: #2f96b4; + *background-color: #2a85a0; +} + +.btn-info:active, +.btn-info.active { + background-color: #24748c \9; +} + +.btn-inverse { + color: #ffffff; + text-shadow: 0 -1px 0 rgba(0, 0, 0, 0.25); + background-color: #363636; + *background-color: #222222; + background-image: -moz-linear-gradient(top, #444444, #222222); + background-image: -webkit-gradient(linear, 0 0, 0 100%, from(#444444), to(#222222)); + background-image: -webkit-linear-gradient(top, #444444, #222222); + background-image: -o-linear-gradient(top, #444444, #222222); + background-image: linear-gradient(to bottom, #444444, #222222); + background-repeat: repeat-x; + border-color: #222222 #222222 #000000; + border-color: rgba(0, 0, 0, 0.1) rgba(0, 0, 0, 0.1) rgba(0, 0, 0, 0.25); + filter: progid:DXImageTransform.Microsoft.gradient(startColorstr='#ff444444', endColorstr='#ff222222', GradientType=0); + filter: progid:DXImageTransform.Microsoft.gradient(enabled=false); +} + +.btn-inverse:hover, +.btn-inverse:active, +.btn-inverse.active, +.btn-inverse.disabled, +.btn-inverse[disabled] { + color: #ffffff; + background-color: #222222; + *background-color: #151515; +} + +.btn-inverse:active, +.btn-inverse.active { + background-color: #080808 \9; +} + +button.btn, +input[type="submit"].btn { + *padding-top: 3px; + *padding-bottom: 3px; +} + +button.btn::-moz-focus-inner, +input[type="submit"].btn::-moz-focus-inner { + padding: 0; + border: 0; +} + +button.btn.btn-large, +input[type="submit"].btn.btn-large { + *padding-top: 7px; + *padding-bottom: 7px; +} + +button.btn.btn-small, +input[type="submit"].btn.btn-small { + *padding-top: 3px; + *padding-bottom: 3px; +} + +button.btn.btn-mini, +input[type="submit"].btn.btn-mini { + *padding-top: 1px; + *padding-bottom: 1px; +} + +.btn-link, +.btn-link:active, +.btn-link[disabled] { + background-color: transparent; + background-image: none; + -webkit-box-shadow: none; + -moz-box-shadow: none; + box-shadow: none; +} + +.btn-link { + color: #0088cc; + cursor: pointer; + border-color: transparent; + -webkit-border-radius: 0; + -moz-border-radius: 0; + border-radius: 0; +} + +.btn-link:hover { + color: #005580; + text-decoration: underline; + background-color: transparent; +} + +.btn-link[disabled]:hover { + color: #333333; + text-decoration: none; +} + +.btn-group { + position: relative; + display: inline-block; + *display: inline; + *margin-left: .3em; + font-size: 0; + white-space: nowrap; + vertical-align: middle; + *zoom: 1; +} + +.btn-group:first-child { + *margin-left: 0; +} + +.btn-group + .btn-group { + margin-left: 5px; +} + +.btn-toolbar { + margin-top: 10px; + margin-bottom: 10px; + font-size: 0; +} + +.btn-toolbar > .btn + .btn, +.btn-toolbar > .btn-group + .btn, +.btn-toolbar > .btn + .btn-group { + margin-left: 5px; +} + +.btn-group > .btn { + position: relative; + -webkit-border-radius: 0; + -moz-border-radius: 0; + border-radius: 0; +} + +.btn-group > .btn + .btn { + margin-left: -1px; +} + +.btn-group > .btn, +.btn-group > .dropdown-menu, +.btn-group > .popover { + font-size: 14px; +} + +.btn-group > .btn-mini { + font-size: 10.5px; +} + +.btn-group > .btn-small { + font-size: 11.9px; +} + +.btn-group > .btn-large { + font-size: 17.5px; +} + +.btn-group > .btn:first-child { + margin-left: 0; + -webkit-border-bottom-left-radius: 4px; + border-bottom-left-radius: 4px; + -webkit-border-top-left-radius: 4px; + border-top-left-radius: 4px; + -moz-border-radius-bottomleft: 4px; + -moz-border-radius-topleft: 4px; +} + +.btn-group > .btn:last-child, +.btn-group > .dropdown-toggle { + -webkit-border-top-right-radius: 4px; + border-top-right-radius: 4px; + -webkit-border-bottom-right-radius: 4px; + border-bottom-right-radius: 4px; + -moz-border-radius-topright: 4px; + -moz-border-radius-bottomright: 4px; +} + +.btn-group > .btn.large:first-child { + margin-left: 0; + -webkit-border-bottom-left-radius: 6px; + border-bottom-left-radius: 6px; + -webkit-border-top-left-radius: 6px; + border-top-left-radius: 6px; + -moz-border-radius-bottomleft: 6px; + -moz-border-radius-topleft: 6px; +} + +.btn-group > .btn.large:last-child, +.btn-group > .large.dropdown-toggle { + -webkit-border-top-right-radius: 6px; + border-top-right-radius: 6px; + -webkit-border-bottom-right-radius: 6px; + border-bottom-right-radius: 6px; + -moz-border-radius-topright: 6px; + -moz-border-radius-bottomright: 6px; +} + +.btn-group > .btn:hover, +.btn-group > .btn:focus, +.btn-group > .btn:active, +.btn-group > .btn.active { + z-index: 2; +} + +.btn-group .dropdown-toggle:active, +.btn-group.open .dropdown-toggle { + outline: 0; +} + +.btn-group > .btn + .dropdown-toggle { + *padding-top: 5px; + padding-right: 8px; + *padding-bottom: 5px; + padding-left: 8px; + -webkit-box-shadow: inset 1px 0 0 rgba(255, 255, 255, 0.125), inset 0 1px 0 rgba(255, 255, 255, 0.2), 0 1px 2px rgba(0, 0, 0, 0.05); + -moz-box-shadow: inset 1px 0 0 rgba(255, 255, 255, 0.125), inset 0 1px 0 rgba(255, 255, 255, 0.2), 0 1px 2px rgba(0, 0, 0, 0.05); + box-shadow: inset 1px 0 0 rgba(255, 255, 255, 0.125), inset 0 1px 0 rgba(255, 255, 255, 0.2), 0 1px 2px rgba(0, 0, 0, 0.05); +} + +.btn-group > .btn-mini + .dropdown-toggle { + *padding-top: 2px; + padding-right: 5px; + *padding-bottom: 2px; + padding-left: 5px; +} + +.btn-group > .btn-small + .dropdown-toggle { + *padding-top: 5px; + *padding-bottom: 4px; +} + +.btn-group > .btn-large + .dropdown-toggle { + *padding-top: 7px; + padding-right: 12px; + *padding-bottom: 7px; + padding-left: 12px; +} + +.btn-group.open .dropdown-toggle { + background-image: none; + -webkit-box-shadow: inset 0 2px 4px rgba(0, 0, 0, 0.15), 0 1px 2px rgba(0, 0, 0, 0.05); + -moz-box-shadow: inset 0 2px 4px rgba(0, 0, 0, 0.15), 0 1px 2px rgba(0, 0, 0, 0.05); + box-shadow: inset 0 2px 4px rgba(0, 0, 0, 0.15), 0 1px 2px rgba(0, 0, 0, 0.05); +} + +.btn-group.open .btn.dropdown-toggle { + background-color: #e6e6e6; +} + +.btn-group.open .btn-primary.dropdown-toggle { + background-color: #0044cc; +} + +.btn-group.open .btn-warning.dropdown-toggle { + background-color: #f89406; +} + +.btn-group.open .btn-danger.dropdown-toggle { + background-color: #bd362f; +} + +.btn-group.open .btn-success.dropdown-toggle { + background-color: #51a351; +} + +.btn-group.open .btn-info.dropdown-toggle { + background-color: #2f96b4; +} + +.btn-group.open .btn-inverse.dropdown-toggle { + background-color: #222222; +} + +.btn .caret { + margin-top: 8px; + margin-left: 0; +} + +.btn-mini .caret, +.btn-small .caret, +.btn-large .caret { + margin-top: 6px; +} + +.btn-large .caret { + border-top-width: 5px; + border-right-width: 5px; + border-left-width: 5px; +} + +.dropup .btn-large .caret { + border-bottom-width: 5px; +} + +.btn-primary .caret, +.btn-warning .caret, +.btn-danger .caret, +.btn-info .caret, +.btn-success .caret, +.btn-inverse .caret { + border-top-color: #ffffff; + border-bottom-color: #ffffff; +} + +.btn-group-vertical { + display: inline-block; + *display: inline; + /* IE7 inline-block hack */ + + *zoom: 1; +} + +.btn-group-vertical > .btn { + display: block; + float: none; + max-width: 100%; + -webkit-border-radius: 0; + -moz-border-radius: 0; + border-radius: 0; +} + +.btn-group-vertical > .btn + .btn { + margin-top: -1px; + margin-left: 0; +} + +.btn-group-vertical > .btn:first-child { + -webkit-border-radius: 4px 4px 0 0; + -moz-border-radius: 4px 4px 0 0; + border-radius: 4px 4px 0 0; +} + +.btn-group-vertical > .btn:last-child { + -webkit-border-radius: 0 0 4px 4px; + -moz-border-radius: 0 0 4px 4px; + border-radius: 0 0 4px 4px; +} + +.btn-group-vertical > .btn-large:first-child { + -webkit-border-radius: 6px 6px 0 0; + -moz-border-radius: 6px 6px 0 0; + border-radius: 6px 6px 0 0; +} + +.btn-group-vertical > .btn-large:last-child { + -webkit-border-radius: 0 0 6px 6px; + -moz-border-radius: 0 0 6px 6px; + border-radius: 0 0 6px 6px; +} + +.alert { + padding: 8px 35px 8px 14px; + margin-bottom: 20px; + text-shadow: 0 1px 0 rgba(255, 255, 255, 0.5); + background-color: #fcf8e3; + border: 1px solid #fbeed5; + -webkit-border-radius: 4px; + -moz-border-radius: 4px; + border-radius: 4px; +} + +.alert, +.alert h4 { + color: #c09853; +} + +.alert h4 { + margin: 0; +} + +.alert .close { + position: relative; + top: -2px; + right: -21px; + line-height: 20px; +} + +.alert-success { + color: #468847; + background-color: #dff0d8; + border-color: #d6e9c6; +} + +.alert-success h4 { + color: #468847; +} + +.alert-danger, +.alert-error { + color: #b94a48; + background-color: #f2dede; + border-color: #eed3d7; +} + +.alert-danger h4, +.alert-error h4 { + color: #b94a48; +} + +.alert-info { + color: #3a87ad; + background-color: #d9edf7; + border-color: #bce8f1; +} + +.alert-info h4 { + color: #3a87ad; +} + +.alert-block { + padding-top: 14px; + padding-bottom: 14px; +} + +.alert-block > p, +.alert-block > ul { + margin-bottom: 0; +} + +.alert-block p + p { + margin-top: 5px; +} + +.nav { + margin-bottom: 20px; + margin-left: 0; + list-style: none; +} + +.nav > li > a { + display: block; +} + +.nav > li > a:hover { + text-decoration: none; + background-color: #eeeeee; +} + +.nav > li > a > img { + max-width: none; +} + +.nav > .pull-right { + float: right; +} + +.nav-header { + display: block; + padding: 3px 15px; + font-size: 11px; + font-weight: bold; + line-height: 20px; + color: #999999; + text-shadow: 0 1px 0 rgba(255, 255, 255, 0.5); + text-transform: uppercase; +} + +.nav li + .nav-header { + margin-top: 9px; +} + +.nav-list { + padding-right: 15px; + padding-left: 15px; + margin-bottom: 0; +} + +.nav-list > li > a, +.nav-list .nav-header { + margin-right: -15px; + margin-left: -15px; + text-shadow: 0 1px 0 rgba(255, 255, 255, 0.5); +} + +.nav-list > li > a { + padding: 3px 15px; +} + +.nav-list > .active > a, +.nav-list > .active > a:hover { + color: #ffffff; + text-shadow: 0 -1px 0 rgba(0, 0, 0, 0.2); + background-color: #0088cc; +} + +.nav-list [class^="icon-"], +.nav-list [class*=" icon-"] { + margin-right: 2px; +} + +.nav-list .divider { + *width: 100%; + height: 1px; + margin: 9px 1px; + *margin: -5px 0 5px; + overflow: hidden; + background-color: #e5e5e5; + border-bottom: 1px solid #ffffff; +} + +.nav-tabs, +.nav-pills { + *zoom: 1; +} + +.nav-tabs:before, +.nav-pills:before, +.nav-tabs:after, +.nav-pills:after { + display: table; + line-height: 0; + content: ""; +} + +.nav-tabs:after, +.nav-pills:after { + clear: both; +} + +.nav-tabs > li, +.nav-pills > li { + float: left; +} + +.nav-tabs > li > a, +.nav-pills > li > a { + padding-right: 12px; + padding-left: 12px; + margin-right: 2px; + line-height: 14px; +} + +.nav-tabs { + border-bottom: 1px solid #ddd; +} + +.nav-tabs > li { + margin-bottom: -1px; +} + +.nav-tabs > li > a { + padding-top: 8px; + padding-bottom: 8px; + line-height: 20px; + border: 1px solid transparent; + -webkit-border-radius: 4px 4px 0 0; + -moz-border-radius: 4px 4px 0 0; + border-radius: 4px 4px 0 0; +} + +.nav-tabs > li > a:hover { + border-color: #eeeeee #eeeeee #dddddd; +} + +.nav-tabs > .active > a, +.nav-tabs > .active > a:hover { + color: #555555; + cursor: default; + background-color: #ffffff; + border: 1px solid #ddd; + border-bottom-color: transparent; +} + +.nav-pills > li > a { + padding-top: 8px; + padding-bottom: 8px; + margin-top: 2px; + margin-bottom: 2px; + -webkit-border-radius: 5px; + -moz-border-radius: 5px; + border-radius: 5px; +} + +.nav-pills > .active > a, +.nav-pills > .active > a:hover { + color: #ffffff; + background-color: #0088cc; +} + +.nav-stacked > li { + float: none; +} + +.nav-stacked > li > a { + margin-right: 0; +} + +.nav-tabs.nav-stacked { + border-bottom: 0; +} + +.nav-tabs.nav-stacked > li > a { + border: 1px solid #ddd; + -webkit-border-radius: 0; + -moz-border-radius: 0; + border-radius: 0; +} + +.nav-tabs.nav-stacked > li:first-child > a { + -webkit-border-top-right-radius: 4px; + border-top-right-radius: 4px; + -webkit-border-top-left-radius: 4px; + border-top-left-radius: 4px; + -moz-border-radius-topright: 4px; + -moz-border-radius-topleft: 4px; +} + +.nav-tabs.nav-stacked > li:last-child > a { + -webkit-border-bottom-right-radius: 4px; + border-bottom-right-radius: 4px; + -webkit-border-bottom-left-radius: 4px; + border-bottom-left-radius: 4px; + -moz-border-radius-bottomright: 4px; + -moz-border-radius-bottomleft: 4px; +} + +.nav-tabs.nav-stacked > li > a:hover { + z-index: 2; + border-color: #ddd; +} + +.nav-pills.nav-stacked > li > a { + margin-bottom: 3px; +} + +.nav-pills.nav-stacked > li:last-child > a { + margin-bottom: 1px; +} + +.nav-tabs .dropdown-menu { + -webkit-border-radius: 0 0 6px 6px; + -moz-border-radius: 0 0 6px 6px; + border-radius: 0 0 6px 6px; +} + +.nav-pills .dropdown-menu { + -webkit-border-radius: 6px; + -moz-border-radius: 6px; + border-radius: 6px; +} + +.nav .dropdown-toggle .caret { + margin-top: 6px; + border-top-color: #0088cc; + border-bottom-color: #0088cc; +} + +.nav .dropdown-toggle:hover .caret { + border-top-color: #005580; + border-bottom-color: #005580; +} + +/* move down carets for tabs */ + +.nav-tabs .dropdown-toggle .caret { + margin-top: 8px; +} + +.nav .active .dropdown-toggle .caret { + border-top-color: #fff; + border-bottom-color: #fff; +} + +.nav-tabs .active .dropdown-toggle .caret { + border-top-color: #555555; + border-bottom-color: #555555; +} + +.nav > .dropdown.active > a:hover { + cursor: pointer; +} + +.nav-tabs .open .dropdown-toggle, +.nav-pills .open .dropdown-toggle, +.nav > li.dropdown.open.active > a:hover { + color: #ffffff; + background-color: #999999; + border-color: #999999; +} + +.nav li.dropdown.open .caret, +.nav li.dropdown.open.active .caret, +.nav li.dropdown.open a:hover .caret { + border-top-color: #ffffff; + border-bottom-color: #ffffff; + opacity: 1; + filter: alpha(opacity=100); +} + +.tabs-stacked .open > a:hover { + border-color: #999999; +} + +.tabbable { + *zoom: 1; +} + +.tabbable:before, +.tabbable:after { + display: table; + line-height: 0; + content: ""; +} + +.tabbable:after { + clear: both; +} + +.tab-content { + overflow: auto; +} + +.tabs-below > .nav-tabs, +.tabs-right > .nav-tabs, +.tabs-left > .nav-tabs { + border-bottom: 0; +} + +.tab-content > .tab-pane, +.pill-content > .pill-pane { + display: none; +} + +.tab-content > .active, +.pill-content > .active { + display: block; +} + +.tabs-below > .nav-tabs { + border-top: 1px solid #ddd; +} + +.tabs-below > .nav-tabs > li { + margin-top: -1px; + margin-bottom: 0; +} + +.tabs-below > .nav-tabs > li > a { + -webkit-border-radius: 0 0 4px 4px; + -moz-border-radius: 0 0 4px 4px; + border-radius: 0 0 4px 4px; +} + +.tabs-below > .nav-tabs > li > a:hover { + border-top-color: #ddd; + border-bottom-color: transparent; +} + +.tabs-below > .nav-tabs > .active > a, +.tabs-below > .nav-tabs > .active > a:hover { + border-color: transparent #ddd #ddd #ddd; +} + +.tabs-left > .nav-tabs > li, +.tabs-right > .nav-tabs > li { + float: none; +} + +.tabs-left > .nav-tabs > li > a, +.tabs-right > .nav-tabs > li > a { + min-width: 74px; + margin-right: 0; + margin-bottom: 3px; +} + +.tabs-left > .nav-tabs { + float: left; + margin-right: 19px; + border-right: 1px solid #ddd; +} + +.tabs-left > .nav-tabs > li > a { + margin-right: -1px; + -webkit-border-radius: 4px 0 0 4px; + -moz-border-radius: 4px 0 0 4px; + border-radius: 4px 0 0 4px; +} + +.tabs-left > .nav-tabs > li > a:hover { + border-color: #eeeeee #dddddd #eeeeee #eeeeee; +} + +.tabs-left > .nav-tabs .active > a, +.tabs-left > .nav-tabs .active > a:hover { + border-color: #ddd transparent #ddd #ddd; + *border-right-color: #ffffff; +} + +.tabs-right > .nav-tabs { + float: right; + margin-left: 19px; + border-left: 1px solid #ddd; +} + +.tabs-right > .nav-tabs > li > a { + margin-left: -1px; + -webkit-border-radius: 0 4px 4px 0; + -moz-border-radius: 0 4px 4px 0; + border-radius: 0 4px 4px 0; +} + +.tabs-right > .nav-tabs > li > a:hover { + border-color: #eeeeee #eeeeee #eeeeee #dddddd; +} + +.tabs-right > .nav-tabs .active > a, +.tabs-right > .nav-tabs .active > a:hover { + border-color: #ddd #ddd #ddd transparent; + *border-left-color: #ffffff; +} + +.nav > .disabled > a { + color: #999999; +} + +.nav > .disabled > a:hover { + text-decoration: none; + cursor: default; + background-color: transparent; +} + +.navbar { + *position: relative; + *z-index: 2; + margin-bottom: 20px; + overflow: visible; +} + +.navbar-inner { + min-height: 40px; + padding-right: 20px; + padding-left: 20px; + background-color: #fafafa; + background-image: -moz-linear-gradient(top, #ffffff, #f2f2f2); + background-image: -webkit-gradient(linear, 0 0, 0 100%, from(#ffffff), to(#f2f2f2)); + background-image: -webkit-linear-gradient(top, #ffffff, #f2f2f2); + background-image: -o-linear-gradient(top, #ffffff, #f2f2f2); + background-image: linear-gradient(to bottom, #ffffff, #f2f2f2); + background-repeat: repeat-x; + border: 1px solid #d4d4d4; + -webkit-border-radius: 4px; + -moz-border-radius: 4px; + border-radius: 4px; + filter: progid:DXImageTransform.Microsoft.gradient(startColorstr='#ffffffff', endColorstr='#fff2f2f2', GradientType=0); + *zoom: 1; + -webkit-box-shadow: 0 1px 4px rgba(0, 0, 0, 0.065); + -moz-box-shadow: 0 1px 4px rgba(0, 0, 0, 0.065); + box-shadow: 0 1px 4px rgba(0, 0, 0, 0.065); +} + +.navbar-inner:before, +.navbar-inner:after { + display: table; + line-height: 0; + content: ""; +} + +.navbar-inner:after { + clear: both; +} + +.navbar .container { + width: auto; +} + +.nav-collapse.collapse { + height: auto; + overflow: visible; +} + +.navbar .brand { + display: block; + float: left; + padding: 10px 20px 10px; + margin-left: -20px; + font-size: 20px; + font-weight: 200; + color: #777777; + text-shadow: 0 1px 0 #ffffff; +} + +.navbar .brand:hover { + text-decoration: none; +} + +.navbar-text { + margin-bottom: 0; + line-height: 40px; + color: #777777; +} + +.navbar-link { + color: #777777; +} + +.navbar-link:hover { + color: #333333; +} + +.navbar .divider-vertical { + height: 40px; + margin: 0 9px; + border-right: 1px solid #ffffff; + border-left: 1px solid #f2f2f2; +} + +.navbar .btn, +.navbar .btn-group { + margin-top: 5px; +} + +.navbar .btn-group .btn, +.navbar .input-prepend .btn, +.navbar .input-append .btn { + margin-top: 0; +} + +.navbar-form { + margin-bottom: 0; + *zoom: 1; +} + +.navbar-form:before, +.navbar-form:after { + display: table; + line-height: 0; + content: ""; +} + +.navbar-form:after { + clear: both; +} + +.navbar-form input, +.navbar-form select, +.navbar-form .radio, +.navbar-form .checkbox { + margin-top: 5px; +} + +.navbar-form input, +.navbar-form select, +.navbar-form .btn { + display: inline-block; + margin-bottom: 0; +} + +.navbar-form input[type="image"], +.navbar-form input[type="checkbox"], +.navbar-form input[type="radio"] { + margin-top: 3px; +} + +.navbar-form .input-append, +.navbar-form .input-prepend { + margin-top: 5px; + white-space: nowrap; +} + +.navbar-form .input-append input, +.navbar-form .input-prepend input { + margin-top: 0; +} + +.navbar-search { + position: relative; + float: left; + margin-top: 5px; + margin-bottom: 0; +} + +.navbar-search .search-query { + padding: 4px 14px; + margin-bottom: 0; + font-family: "Helvetica Neue", Helvetica, Arial, sans-serif; + font-size: 13px; + font-weight: normal; + line-height: 1; + -webkit-border-radius: 15px; + -moz-border-radius: 15px; + border-radius: 15px; +} + +.navbar-static-top { + position: static; + margin-bottom: 0; +} + +.navbar-static-top .navbar-inner { + -webkit-border-radius: 0; + -moz-border-radius: 0; + border-radius: 0; +} + +.navbar-fixed-top, +.navbar-fixed-bottom { + position: fixed; + right: 0; + left: 0; + z-index: 1030; + margin-bottom: 0; +} + +.navbar-fixed-top .navbar-inner, +.navbar-static-top .navbar-inner { + border-width: 0 0 1px; +} + +.navbar-fixed-bottom .navbar-inner { + border-width: 1px 0 0; +} + +.navbar-fixed-top .navbar-inner, +.navbar-fixed-bottom .navbar-inner { + padding-right: 0; + padding-left: 0; + -webkit-border-radius: 0; + -moz-border-radius: 0; + border-radius: 0; +} + +.navbar-static-top .container, +.navbar-fixed-top .container, +.navbar-fixed-bottom .container { + width: 940px; +} + +.navbar-fixed-top { + top: 0; +} + +.navbar-fixed-top .navbar-inner, +.navbar-static-top .navbar-inner { + -webkit-box-shadow: 0 1px 10px rgba(0, 0, 0, 0.1); + -moz-box-shadow: 0 1px 10px rgba(0, 0, 0, 0.1); + box-shadow: 0 1px 10px rgba(0, 0, 0, 0.1); +} + +.navbar-fixed-bottom { + bottom: 0; +} + +.navbar-fixed-bottom .navbar-inner { + -webkit-box-shadow: 0 -1px 10px rgba(0, 0, 0, 0.1); + -moz-box-shadow: 0 -1px 10px rgba(0, 0, 0, 0.1); + box-shadow: 0 -1px 10px rgba(0, 0, 0, 0.1); +} + +.navbar .nav { + position: relative; + left: 0; + display: block; + float: left; + margin: 0 10px 0 0; +} + +.navbar .nav.pull-right { + float: right; + margin-right: 0; +} + +.navbar .nav > li { + float: left; +} + +.navbar .nav > li > a { + float: none; + padding: 10px 15px 10px; + color: #777777; + text-decoration: none; + text-shadow: 0 1px 0 #ffffff; +} + +.navbar .nav .dropdown-toggle .caret { + margin-top: 8px; +} + +.navbar .nav > li > a:focus, +.navbar .nav > li > a:hover { + color: #333333; + text-decoration: none; + background-color: transparent; +} + +.navbar .nav > .active > a, +.navbar .nav > .active > a:hover, +.navbar .nav > .active > a:focus { + color: #555555; + text-decoration: none; + background-color: #e5e5e5; + -webkit-box-shadow: inset 0 3px 8px rgba(0, 0, 0, 0.125); + -moz-box-shadow: inset 0 3px 8px rgba(0, 0, 0, 0.125); + box-shadow: inset 0 3px 8px rgba(0, 0, 0, 0.125); +} + +.navbar .btn-navbar { + display: none; + float: right; + padding: 7px 10px; + margin-right: 5px; + margin-left: 5px; + color: #ffffff; + text-shadow: 0 -1px 0 rgba(0, 0, 0, 0.25); + background-color: #ededed; + *background-color: #e5e5e5; + background-image: -moz-linear-gradient(top, #f2f2f2, #e5e5e5); + background-image: -webkit-gradient(linear, 0 0, 0 100%, from(#f2f2f2), to(#e5e5e5)); + background-image: -webkit-linear-gradient(top, #f2f2f2, #e5e5e5); + background-image: -o-linear-gradient(top, #f2f2f2, #e5e5e5); + background-image: linear-gradient(to bottom, #f2f2f2, #e5e5e5); + background-repeat: repeat-x; + border-color: #e5e5e5 #e5e5e5 #bfbfbf; + border-color: rgba(0, 0, 0, 0.1) rgba(0, 0, 0, 0.1) rgba(0, 0, 0, 0.25); + filter: progid:DXImageTransform.Microsoft.gradient(startColorstr='#fff2f2f2', endColorstr='#ffe5e5e5', GradientType=0); + filter: progid:DXImageTransform.Microsoft.gradient(enabled=false); + -webkit-box-shadow: inset 0 1px 0 rgba(255, 255, 255, 0.1), 0 1px 0 rgba(255, 255, 255, 0.075); + -moz-box-shadow: inset 0 1px 0 rgba(255, 255, 255, 0.1), 0 1px 0 rgba(255, 255, 255, 0.075); + box-shadow: inset 0 1px 0 rgba(255, 255, 255, 0.1), 0 1px 0 rgba(255, 255, 255, 0.075); +} + +.navbar .btn-navbar:hover, +.navbar .btn-navbar:active, +.navbar .btn-navbar.active, +.navbar .btn-navbar.disabled, +.navbar .btn-navbar[disabled] { + color: #ffffff; + background-color: #e5e5e5; + *background-color: #d9d9d9; +} + +.navbar .btn-navbar:active, +.navbar .btn-navbar.active { + background-color: #cccccc \9; +} + +.navbar .btn-navbar .icon-bar { + display: block; + width: 18px; + height: 2px; + background-color: #f5f5f5; + -webkit-border-radius: 1px; + -moz-border-radius: 1px; + border-radius: 1px; + -webkit-box-shadow: 0 1px 0 rgba(0, 0, 0, 0.25); + -moz-box-shadow: 0 1px 0 rgba(0, 0, 0, 0.25); + box-shadow: 0 1px 0 rgba(0, 0, 0, 0.25); +} + +.btn-navbar .icon-bar + .icon-bar { + margin-top: 3px; +} + +.navbar .nav > li > .dropdown-menu:before { + position: absolute; + top: -7px; + left: 9px; + display: inline-block; + border-right: 7px solid transparent; + border-bottom: 7px solid #ccc; + border-left: 7px solid transparent; + border-bottom-color: rgba(0, 0, 0, 0.2); + content: ''; +} + +.navbar .nav > li > .dropdown-menu:after { + position: absolute; + top: -6px; + left: 10px; + display: inline-block; + border-right: 6px solid transparent; + border-bottom: 6px solid #ffffff; + border-left: 6px solid transparent; + content: ''; +} + +.navbar-fixed-bottom .nav > li > .dropdown-menu:before { + top: auto; + bottom: -7px; + border-top: 7px solid #ccc; + border-bottom: 0; + border-top-color: rgba(0, 0, 0, 0.2); +} + +.navbar-fixed-bottom .nav > li > .dropdown-menu:after { + top: auto; + bottom: -6px; + border-top: 6px solid #ffffff; + border-bottom: 0; +} + +.navbar .nav li.dropdown > a:hover .caret { + border-top-color: #555555; + border-bottom-color: #555555; +} + +.navbar .nav li.dropdown.open > .dropdown-toggle, +.navbar .nav li.dropdown.active > .dropdown-toggle, +.navbar .nav li.dropdown.open.active > .dropdown-toggle { + color: #555555; + background-color: #e5e5e5; +} + +.navbar .nav li.dropdown > .dropdown-toggle .caret { + border-top-color: #777777; + border-bottom-color: #777777; +} + +.navbar .nav li.dropdown.open > .dropdown-toggle .caret, +.navbar .nav li.dropdown.active > .dropdown-toggle .caret, +.navbar .nav li.dropdown.open.active > .dropdown-toggle .caret { + border-top-color: #555555; + border-bottom-color: #555555; +} + +.navbar .pull-right > li > .dropdown-menu, +.navbar .nav > li > .dropdown-menu.pull-right { + right: 0; + left: auto; +} + +.navbar .pull-right > li > .dropdown-menu:before, +.navbar .nav > li > .dropdown-menu.pull-right:before { + right: 12px; + left: auto; +} + +.navbar .pull-right > li > .dropdown-menu:after, +.navbar .nav > li > .dropdown-menu.pull-right:after { + right: 13px; + left: auto; +} + +.navbar .pull-right > li > .dropdown-menu .dropdown-menu, +.navbar .nav > li > .dropdown-menu.pull-right .dropdown-menu { + right: 100%; + left: auto; + margin-right: -1px; + margin-left: 0; + -webkit-border-radius: 6px 0 6px 6px; + -moz-border-radius: 6px 0 6px 6px; + border-radius: 6px 0 6px 6px; +} + +.navbar-inverse .navbar-inner { + background-color: #1b1b1b; + background-image: -moz-linear-gradient(top, #222222, #111111); + background-image: -webkit-gradient(linear, 0 0, 0 100%, from(#222222), to(#111111)); + background-image: -webkit-linear-gradient(top, #222222, #111111); + background-image: -o-linear-gradient(top, #222222, #111111); + background-image: linear-gradient(to bottom, #222222, #111111); + background-repeat: repeat-x; + border-color: #252525; + filter: progid:DXImageTransform.Microsoft.gradient(startColorstr='#ff222222', endColorstr='#ff111111', GradientType=0); +} + +.navbar-inverse .brand, +.navbar-inverse .nav > li > a { + color: #999999; + text-shadow: 0 -1px 0 rgba(0, 0, 0, 0.25); +} + +.navbar-inverse .brand:hover, +.navbar-inverse .nav > li > a:hover { + color: #ffffff; +} + +.navbar-inverse .brand { + color: #999999; +} + +.navbar-inverse .navbar-text { + color: #999999; +} + +.navbar-inverse .nav > li > a:focus, +.navbar-inverse .nav > li > a:hover { + color: #ffffff; + background-color: transparent; +} + +.navbar-inverse .nav .active > a, +.navbar-inverse .nav .active > a:hover, +.navbar-inverse .nav .active > a:focus { + color: #ffffff; + background-color: #111111; +} + +.navbar-inverse .navbar-link { + color: #999999; +} + +.navbar-inverse .navbar-link:hover { + color: #ffffff; +} + +.navbar-inverse .divider-vertical { + border-right-color: #222222; + border-left-color: #111111; +} + +.navbar-inverse .nav li.dropdown.open > .dropdown-toggle, +.navbar-inverse .nav li.dropdown.active > .dropdown-toggle, +.navbar-inverse .nav li.dropdown.open.active > .dropdown-toggle { + color: #ffffff; + background-color: #111111; +} + +.navbar-inverse .nav li.dropdown > a:hover .caret { + border-top-color: #ffffff; + border-bottom-color: #ffffff; +} + +.navbar-inverse .nav li.dropdown > .dropdown-toggle .caret { + border-top-color: #999999; + border-bottom-color: #999999; +} + +.navbar-inverse .nav li.dropdown.open > .dropdown-toggle .caret, +.navbar-inverse .nav li.dropdown.active > .dropdown-toggle .caret, +.navbar-inverse .nav li.dropdown.open.active > .dropdown-toggle .caret { + border-top-color: #ffffff; + border-bottom-color: #ffffff; +} + +.navbar-inverse .navbar-search .search-query { + color: #ffffff; + background-color: #515151; + border-color: #111111; + -webkit-box-shadow: inset 0 1px 2px rgba(0, 0, 0, 0.1), 0 1px 0 rgba(255, 255, 255, 0.15); + -moz-box-shadow: inset 0 1px 2px rgba(0, 0, 0, 0.1), 0 1px 0 rgba(255, 255, 255, 0.15); + box-shadow: inset 0 1px 2px rgba(0, 0, 0, 0.1), 0 1px 0 rgba(255, 255, 255, 0.15); + -webkit-transition: none; + -moz-transition: none; + -o-transition: none; + transition: none; +} + +.navbar-inverse .navbar-search .search-query:-moz-placeholder { + color: #cccccc; +} + +.navbar-inverse .navbar-search .search-query:-ms-input-placeholder { + color: #cccccc; +} + +.navbar-inverse .navbar-search .search-query::-webkit-input-placeholder { + color: #cccccc; +} + +.navbar-inverse .navbar-search .search-query:focus, +.navbar-inverse .navbar-search .search-query.focused { + padding: 5px 15px; + color: #333333; + text-shadow: 0 1px 0 #ffffff; + background-color: #ffffff; + border: 0; + outline: 0; + -webkit-box-shadow: 0 0 3px rgba(0, 0, 0, 0.15); + -moz-box-shadow: 0 0 3px rgba(0, 0, 0, 0.15); + box-shadow: 0 0 3px rgba(0, 0, 0, 0.15); +} + +.navbar-inverse .btn-navbar { + color: #ffffff; + text-shadow: 0 -1px 0 rgba(0, 0, 0, 0.25); + background-color: #0e0e0e; + *background-color: #040404; + background-image: -moz-linear-gradient(top, #151515, #040404); + background-image: -webkit-gradient(linear, 0 0, 0 100%, from(#151515), to(#040404)); + background-image: -webkit-linear-gradient(top, #151515, #040404); + background-image: -o-linear-gradient(top, #151515, #040404); + background-image: linear-gradient(to bottom, #151515, #040404); + background-repeat: repeat-x; + border-color: #040404 #040404 #000000; + border-color: rgba(0, 0, 0, 0.1) rgba(0, 0, 0, 0.1) rgba(0, 0, 0, 0.25); + filter: progid:DXImageTransform.Microsoft.gradient(startColorstr='#ff151515', endColorstr='#ff040404', GradientType=0); + filter: progid:DXImageTransform.Microsoft.gradient(enabled=false); +} + +.navbar-inverse .btn-navbar:hover, +.navbar-inverse .btn-navbar:active, +.navbar-inverse .btn-navbar.active, +.navbar-inverse .btn-navbar.disabled, +.navbar-inverse .btn-navbar[disabled] { + color: #ffffff; + background-color: #040404; + *background-color: #000000; +} + +.navbar-inverse .btn-navbar:active, +.navbar-inverse .btn-navbar.active { + background-color: #000000 \9; +} + +.breadcrumb { + padding: 8px 15px; + margin: 0 0 20px; + list-style: none; + background-color: #f5f5f5; + -webkit-border-radius: 4px; + -moz-border-radius: 4px; + border-radius: 4px; +} + +.breadcrumb > li { + display: inline-block; + *display: inline; + text-shadow: 0 1px 0 #ffffff; + *zoom: 1; +} + +.breadcrumb > li > .divider { + padding: 0 5px; + color: #ccc; +} + +.breadcrumb > .active { + color: #999999; +} + +.pagination { + margin: 20px 0; +} + +.pagination ul { + display: inline-block; + *display: inline; + margin-bottom: 0; + margin-left: 0; + -webkit-border-radius: 4px; + -moz-border-radius: 4px; + border-radius: 4px; + *zoom: 1; + -webkit-box-shadow: 0 1px 2px rgba(0, 0, 0, 0.05); + -moz-box-shadow: 0 1px 2px rgba(0, 0, 0, 0.05); + box-shadow: 0 1px 2px rgba(0, 0, 0, 0.05); +} + +.pagination ul > li { + display: inline; +} + +.pagination ul > li > a, +.pagination ul > li > span { + float: left; + padding: 4px 12px; + line-height: 20px; + text-decoration: none; + background-color: #ffffff; + border: 1px solid #dddddd; + border-left-width: 0; +} + +.pagination ul > li > a:hover, +.pagination ul > .active > a, +.pagination ul > .active > span { + background-color: #f5f5f5; +} + +.pagination ul > .active > a, +.pagination ul > .active > span { + color: #999999; + cursor: default; +} + +.pagination ul > .disabled > span, +.pagination ul > .disabled > a, +.pagination ul > .disabled > a:hover { + color: #999999; + cursor: default; + background-color: transparent; +} + +.pagination ul > li:first-child > a, +.pagination ul > li:first-child > span { + border-left-width: 1px; + -webkit-border-bottom-left-radius: 4px; + border-bottom-left-radius: 4px; + -webkit-border-top-left-radius: 4px; + border-top-left-radius: 4px; + -moz-border-radius-bottomleft: 4px; + -moz-border-radius-topleft: 4px; +} + +.pagination ul > li:last-child > a, +.pagination ul > li:last-child > span { + -webkit-border-top-right-radius: 4px; + border-top-right-radius: 4px; + -webkit-border-bottom-right-radius: 4px; + border-bottom-right-radius: 4px; + -moz-border-radius-topright: 4px; + -moz-border-radius-bottomright: 4px; +} + +.pagination-centered { + text-align: center; +} + +.pagination-right { + text-align: right; +} + +.pagination-large ul > li > a, +.pagination-large ul > li > span { + padding: 11px 19px; + font-size: 17.5px; +} + +.pagination-large ul > li:first-child > a, +.pagination-large ul > li:first-child > span { + -webkit-border-bottom-left-radius: 6px; + border-bottom-left-radius: 6px; + -webkit-border-top-left-radius: 6px; + border-top-left-radius: 6px; + -moz-border-radius-bottomleft: 6px; + -moz-border-radius-topleft: 6px; +} + +.pagination-large ul > li:last-child > a, +.pagination-large ul > li:last-child > span { + -webkit-border-top-right-radius: 6px; + border-top-right-radius: 6px; + -webkit-border-bottom-right-radius: 6px; + border-bottom-right-radius: 6px; + -moz-border-radius-topright: 6px; + -moz-border-radius-bottomright: 6px; +} + +.pagination-mini ul > li:first-child > a, +.pagination-small ul > li:first-child > a, +.pagination-mini ul > li:first-child > span, +.pagination-small ul > li:first-child > span { + -webkit-border-bottom-left-radius: 3px; + border-bottom-left-radius: 3px; + -webkit-border-top-left-radius: 3px; + border-top-left-radius: 3px; + -moz-border-radius-bottomleft: 3px; + -moz-border-radius-topleft: 3px; +} + +.pagination-mini ul > li:last-child > a, +.pagination-small ul > li:last-child > a, +.pagination-mini ul > li:last-child > span, +.pagination-small ul > li:last-child > span { + -webkit-border-top-right-radius: 3px; + border-top-right-radius: 3px; + -webkit-border-bottom-right-radius: 3px; + border-bottom-right-radius: 3px; + -moz-border-radius-topright: 3px; + -moz-border-radius-bottomright: 3px; +} + +.pagination-small ul > li > a, +.pagination-small ul > li > span { + padding: 2px 10px; + font-size: 11.9px; +} + +.pagination-mini ul > li > a, +.pagination-mini ul > li > span { + padding: 0 6px; + font-size: 10.5px; +} + +.pager { + margin: 20px 0; + text-align: center; + list-style: none; + *zoom: 1; +} + +.pager:before, +.pager:after { + display: table; + line-height: 0; + content: ""; +} + +.pager:after { + clear: both; +} + +.pager li { + display: inline; +} + +.pager li > a, +.pager li > span { + display: inline-block; + padding: 5px 14px; + background-color: #fff; + border: 1px solid #ddd; + -webkit-border-radius: 15px; + -moz-border-radius: 15px; + border-radius: 15px; +} + +.pager li > a:hover { + text-decoration: none; + background-color: #f5f5f5; +} + +.pager .next > a, +.pager .next > span { + float: right; +} + +.pager .previous > a, +.pager .previous > span { + float: left; +} + +.pager .disabled > a, +.pager .disabled > a:hover, +.pager .disabled > span { + color: #999999; + cursor: default; + background-color: #fff; +} + +.modal-backdrop { + position: fixed; + top: 0; + right: 0; + bottom: 0; + left: 0; + z-index: 1040; + background-color: #000000; +} + +.modal-backdrop.fade { + opacity: 0; +} + +.modal-backdrop, +.modal-backdrop.fade.in { + opacity: 0.8; + filter: alpha(opacity=80); +} + +.modal { + position: fixed; + top: 10%; + left: 50%; + z-index: 1050; + width: 560px; + margin-left: -280px; + background-color: #ffffff; + border: 1px solid #999; + border: 1px solid rgba(0, 0, 0, 0.3); + *border: 1px solid #999; + -webkit-border-radius: 6px; + -moz-border-radius: 6px; + border-radius: 6px; + outline: none; + -webkit-box-shadow: 0 3px 7px rgba(0, 0, 0, 0.3); + -moz-box-shadow: 0 3px 7px rgba(0, 0, 0, 0.3); + box-shadow: 0 3px 7px rgba(0, 0, 0, 0.3); + -webkit-background-clip: padding-box; + -moz-background-clip: padding-box; + background-clip: padding-box; +} + +.modal.fade { + top: -25%; + -webkit-transition: opacity 0.3s linear, top 0.3s ease-out; + -moz-transition: opacity 0.3s linear, top 0.3s ease-out; + -o-transition: opacity 0.3s linear, top 0.3s ease-out; + transition: opacity 0.3s linear, top 0.3s ease-out; +} + +.modal.fade.in { + top: 10%; +} + +.modal-header { + padding: 9px 15px; + border-bottom: 1px solid #eee; +} + +.modal-header .close { + margin-top: 2px; +} + +.modal-header h3 { + margin: 0; + line-height: 30px; +} + +.modal-body { + position: relative; + max-height: 400px; + padding: 15px; + overflow-y: auto; +} + +.modal-form { + margin-bottom: 0; +} + +.modal-footer { + padding: 14px 15px 15px; + margin-bottom: 0; + text-align: right; + background-color: #f5f5f5; + border-top: 1px solid #ddd; + -webkit-border-radius: 0 0 6px 6px; + -moz-border-radius: 0 0 6px 6px; + border-radius: 0 0 6px 6px; + *zoom: 1; + -webkit-box-shadow: inset 0 1px 0 #ffffff; + -moz-box-shadow: inset 0 1px 0 #ffffff; + box-shadow: inset 0 1px 0 #ffffff; +} + +.modal-footer:before, +.modal-footer:after { + display: table; + line-height: 0; + content: ""; +} + +.modal-footer:after { + clear: both; +} + +.modal-footer .btn + .btn { + margin-bottom: 0; + margin-left: 5px; +} + +.modal-footer .btn-group .btn + .btn { + margin-left: -1px; +} + +.modal-footer .btn-block + .btn-block { + margin-left: 0; +} + +.tooltip { + position: absolute; + z-index: 1030; + display: block; + padding: 5px; + font-size: 11px; + opacity: 0; + filter: alpha(opacity=0); + visibility: visible; +} + +.tooltip.in { + opacity: 0.8; + filter: alpha(opacity=80); +} + +.tooltip.top { + margin-top: -3px; +} + +.tooltip.right { + margin-left: 3px; +} + +.tooltip.bottom { + margin-top: 3px; +} + +.tooltip.left { + margin-left: -3px; +} + +.tooltip-inner { + max-width: 200px; + padding: 3px 8px; + color: #ffffff; + text-align: center; + text-decoration: none; + background-color: #000000; + -webkit-border-radius: 4px; + -moz-border-radius: 4px; + border-radius: 4px; +} + +.tooltip-arrow { + position: absolute; + width: 0; + height: 0; + border-color: transparent; + border-style: solid; +} + +.tooltip.top .tooltip-arrow { + bottom: 0; + left: 50%; + margin-left: -5px; + border-top-color: #000000; + border-width: 5px 5px 0; +} + +.tooltip.right .tooltip-arrow { + top: 50%; + left: 0; + margin-top: -5px; + border-right-color: #000000; + border-width: 5px 5px 5px 0; +} + +.tooltip.left .tooltip-arrow { + top: 50%; + right: 0; + margin-top: -5px; + border-left-color: #000000; + border-width: 5px 0 5px 5px; +} + +.tooltip.bottom .tooltip-arrow { + top: 0; + left: 50%; + margin-left: -5px; + border-bottom-color: #000000; + border-width: 0 5px 5px; +} + +.popover { + position: absolute; + top: 0; + left: 0; + z-index: 1010; + display: none; + width: 236px; + padding: 1px; + text-align: left; + white-space: normal; + background-color: #ffffff; + border: 1px solid #ccc; + border: 1px solid rgba(0, 0, 0, 0.2); + -webkit-border-radius: 6px; + -moz-border-radius: 6px; + border-radius: 6px; + -webkit-box-shadow: 0 5px 10px rgba(0, 0, 0, 0.2); + -moz-box-shadow: 0 5px 10px rgba(0, 0, 0, 0.2); + box-shadow: 0 5px 10px rgba(0, 0, 0, 0.2); + -webkit-background-clip: padding-box; + -moz-background-clip: padding; + background-clip: padding-box; +} + +.popover.top { + margin-top: -10px; +} + +.popover.right { + margin-left: 10px; +} + +.popover.bottom { + margin-top: 10px; +} + +.popover.left { + margin-left: -10px; +} + +.popover-title { + padding: 8px 14px; + margin: 0; + font-size: 14px; + font-weight: normal; + line-height: 18px; + background-color: #f7f7f7; + border-bottom: 1px solid #ebebeb; + -webkit-border-radius: 5px 5px 0 0; + -moz-border-radius: 5px 5px 0 0; + border-radius: 5px 5px 0 0; +} + +.popover-content { + padding: 9px 14px; +} + +.popover .arrow, +.popover .arrow:after { + position: absolute; + display: block; + width: 0; + height: 0; + border-color: transparent; + border-style: solid; +} + +.popover .arrow { + border-width: 11px; +} + +.popover .arrow:after { + border-width: 10px; + content: ""; +} + +.popover.top .arrow { + bottom: -11px; + left: 50%; + margin-left: -11px; + border-top-color: #999; + border-top-color: rgba(0, 0, 0, 0.25); + border-bottom-width: 0; +} + +.popover.top .arrow:after { + bottom: 1px; + margin-left: -10px; + border-top-color: #ffffff; + border-bottom-width: 0; +} + +.popover.right .arrow { + top: 50%; + left: -11px; + margin-top: -11px; + border-right-color: #999; + border-right-color: rgba(0, 0, 0, 0.25); + border-left-width: 0; +} + +.popover.right .arrow:after { + bottom: -10px; + left: 1px; + border-right-color: #ffffff; + border-left-width: 0; +} + +.popover.bottom .arrow { + top: -11px; + left: 50%; + margin-left: -11px; + border-bottom-color: #999; + border-bottom-color: rgba(0, 0, 0, 0.25); + border-top-width: 0; +} + +.popover.bottom .arrow:after { + top: 1px; + margin-left: -10px; + border-bottom-color: #ffffff; + border-top-width: 0; +} + +.popover.left .arrow { + top: 50%; + right: -11px; + margin-top: -11px; + border-left-color: #999; + border-left-color: rgba(0, 0, 0, 0.25); + border-right-width: 0; +} + +.popover.left .arrow:after { + right: 1px; + bottom: -10px; + border-left-color: #ffffff; + border-right-width: 0; +} + +.thumbnails { + margin-left: -20px; + list-style: none; + *zoom: 1; +} + +.thumbnails:before, +.thumbnails:after { + display: table; + line-height: 0; + content: ""; +} + +.thumbnails:after { + clear: both; +} + +.row-fluid .thumbnails { + margin-left: 0; +} + +.thumbnails > li { + float: left; + margin-bottom: 20px; + margin-left: 20px; +} + +.thumbnail { + display: block; + padding: 4px; + line-height: 20px; + border: 1px solid #ddd; + -webkit-border-radius: 4px; + -moz-border-radius: 4px; + border-radius: 4px; + -webkit-box-shadow: 0 1px 3px rgba(0, 0, 0, 0.055); + -moz-box-shadow: 0 1px 3px rgba(0, 0, 0, 0.055); + box-shadow: 0 1px 3px rgba(0, 0, 0, 0.055); + -webkit-transition: all 0.2s ease-in-out; + -moz-transition: all 0.2s ease-in-out; + -o-transition: all 0.2s ease-in-out; + transition: all 0.2s ease-in-out; +} + +a.thumbnail:hover { + border-color: #0088cc; + -webkit-box-shadow: 0 1px 4px rgba(0, 105, 214, 0.25); + -moz-box-shadow: 0 1px 4px rgba(0, 105, 214, 0.25); + box-shadow: 0 1px 4px rgba(0, 105, 214, 0.25); +} + +.thumbnail > img { + display: block; + max-width: 100%; + margin-right: auto; + margin-left: auto; +} + +.thumbnail .caption { + padding: 9px; + color: #555555; +} + +.media, +.media-body { + overflow: hidden; + *overflow: visible; + zoom: 1; +} + +.media, +.media .media { + margin-top: 15px; +} + +.media:first-child { + margin-top: 0; +} + +.media-object { + display: block; +} + +.media-heading { + margin: 0 0 5px; +} + +.media .pull-left { + margin-right: 10px; +} + +.media .pull-right { + margin-left: 10px; +} + +.media-list { + margin-left: 0; + list-style: none; +} + +.label, +.badge { + display: inline-block; + padding: 2px 4px; + font-size: 11.844px; + font-weight: bold; + line-height: 14px; + color: #ffffff; + text-shadow: 0 -1px 0 rgba(0, 0, 0, 0.25); + white-space: nowrap; + vertical-align: baseline; + background-color: #999999; +} + +.label { + -webkit-border-radius: 3px; + -moz-border-radius: 3px; + border-radius: 3px; +} + +.badge { + padding-right: 9px; + padding-left: 9px; + -webkit-border-radius: 9px; + -moz-border-radius: 9px; + border-radius: 9px; +} + +.label:empty, +.badge:empty { + display: none; +} + +a.label:hover, +a.badge:hover { + color: #ffffff; + text-decoration: none; + cursor: pointer; +} + +.label-important, +.badge-important { + background-color: #b94a48; +} + +.label-important[href], +.badge-important[href] { + background-color: #953b39; +} + +.label-warning, +.badge-warning { + background-color: #f89406; +} + +.label-warning[href], +.badge-warning[href] { + background-color: #c67605; +} + +.label-success, +.badge-success { + background-color: #468847; +} + +.label-success[href], +.badge-success[href] { + background-color: #356635; +} + +.label-info, +.badge-info { + background-color: #3a87ad; +} + +.label-info[href], +.badge-info[href] { + background-color: #2d6987; +} + +.label-inverse, +.badge-inverse { + background-color: #333333; +} + +.label-inverse[href], +.badge-inverse[href] { + background-color: #1a1a1a; +} + +.btn .label, +.btn .badge { + position: relative; + top: -1px; +} + +.btn-mini .label, +.btn-mini .badge { + top: 0; +} + +@-webkit-keyframes progress-bar-stripes { + from { + background-position: 40px 0; + } + to { + background-position: 0 0; + } +} + +@-moz-keyframes progress-bar-stripes { + from { + background-position: 40px 0; + } + to { + background-position: 0 0; + } +} + +@-ms-keyframes progress-bar-stripes { + from { + background-position: 40px 0; + } + to { + background-position: 0 0; + } +} + +@-o-keyframes progress-bar-stripes { + from { + background-position: 0 0; + } + to { + background-position: 40px 0; + } +} + +@keyframes progress-bar-stripes { + from { + background-position: 40px 0; + } + to { + background-position: 0 0; + } +} + +.progress { + height: 20px; + margin-bottom: 20px; + overflow: hidden; + background-color: #f7f7f7; + background-image: -moz-linear-gradient(top, #f5f5f5, #f9f9f9); + background-image: -webkit-gradient(linear, 0 0, 0 100%, from(#f5f5f5), to(#f9f9f9)); + background-image: -webkit-linear-gradient(top, #f5f5f5, #f9f9f9); + background-image: -o-linear-gradient(top, #f5f5f5, #f9f9f9); + background-image: linear-gradient(to bottom, #f5f5f5, #f9f9f9); + background-repeat: repeat-x; + -webkit-border-radius: 4px; + -moz-border-radius: 4px; + border-radius: 4px; + filter: progid:DXImageTransform.Microsoft.gradient(startColorstr='#fff5f5f5', endColorstr='#fff9f9f9', GradientType=0); + -webkit-box-shadow: inset 0 1px 2px rgba(0, 0, 0, 0.1); + -moz-box-shadow: inset 0 1px 2px rgba(0, 0, 0, 0.1); + box-shadow: inset 0 1px 2px rgba(0, 0, 0, 0.1); +} + +.progress .bar { + float: left; + width: 0; + height: 100%; + font-size: 12px; + color: #ffffff; + text-align: center; + text-shadow: 0 -1px 0 rgba(0, 0, 0, 0.25); + background-color: #0e90d2; + background-image: -moz-linear-gradient(top, #149bdf, #0480be); + background-image: -webkit-gradient(linear, 0 0, 0 100%, from(#149bdf), to(#0480be)); + background-image: -webkit-linear-gradient(top, #149bdf, #0480be); + background-image: -o-linear-gradient(top, #149bdf, #0480be); + background-image: linear-gradient(to bottom, #149bdf, #0480be); + background-repeat: repeat-x; + filter: progid:DXImageTransform.Microsoft.gradient(startColorstr='#ff149bdf', endColorstr='#ff0480be', GradientType=0); + -webkit-box-shadow: inset 0 -1px 0 rgba(0, 0, 0, 0.15); + -moz-box-shadow: inset 0 -1px 0 rgba(0, 0, 0, 0.15); + box-shadow: inset 0 -1px 0 rgba(0, 0, 0, 0.15); + -webkit-box-sizing: border-box; + -moz-box-sizing: border-box; + box-sizing: border-box; + -webkit-transition: width 0.6s ease; + -moz-transition: width 0.6s ease; + -o-transition: width 0.6s ease; + transition: width 0.6s ease; +} + +.progress .bar + .bar { + -webkit-box-shadow: inset 1px 0 0 rgba(0, 0, 0, 0.15), inset 0 -1px 0 rgba(0, 0, 0, 0.15); + -moz-box-shadow: inset 1px 0 0 rgba(0, 0, 0, 0.15), inset 0 -1px 0 rgba(0, 0, 0, 0.15); + box-shadow: inset 1px 0 0 rgba(0, 0, 0, 0.15), inset 0 -1px 0 rgba(0, 0, 0, 0.15); +} + +.progress-striped .bar { + background-color: #149bdf; + background-image: -webkit-gradient(linear, 0 100%, 100% 0, color-stop(0.25, rgba(255, 255, 255, 0.15)), color-stop(0.25, transparent), color-stop(0.5, transparent), color-stop(0.5, rgba(255, 255, 255, 0.15)), color-stop(0.75, rgba(255, 255, 255, 0.15)), color-stop(0.75, transparent), to(transparent)); + background-image: -webkit-linear-gradient(45deg, rgba(255, 255, 255, 0.15) 25%, transparent 25%, transparent 50%, rgba(255, 255, 255, 0.15) 50%, rgba(255, 255, 255, 0.15) 75%, transparent 75%, transparent); + background-image: -moz-linear-gradient(45deg, rgba(255, 255, 255, 0.15) 25%, transparent 25%, transparent 50%, rgba(255, 255, 255, 0.15) 50%, rgba(255, 255, 255, 0.15) 75%, transparent 75%, transparent); + background-image: -o-linear-gradient(45deg, rgba(255, 255, 255, 0.15) 25%, transparent 25%, transparent 50%, rgba(255, 255, 255, 0.15) 50%, rgba(255, 255, 255, 0.15) 75%, transparent 75%, transparent); + background-image: linear-gradient(45deg, rgba(255, 255, 255, 0.15) 25%, transparent 25%, transparent 50%, rgba(255, 255, 255, 0.15) 50%, rgba(255, 255, 255, 0.15) 75%, transparent 75%, transparent); + -webkit-background-size: 40px 40px; + -moz-background-size: 40px 40px; + -o-background-size: 40px 40px; + background-size: 40px 40px; +} + +.progress.active .bar { + -webkit-animation: progress-bar-stripes 2s linear infinite; + -moz-animation: progress-bar-stripes 2s linear infinite; + -ms-animation: progress-bar-stripes 2s linear infinite; + -o-animation: progress-bar-stripes 2s linear infinite; + animation: progress-bar-stripes 2s linear infinite; +} + +.progress-danger .bar, +.progress .bar-danger { + background-color: #dd514c; + background-image: -moz-linear-gradient(top, #ee5f5b, #c43c35); + background-image: -webkit-gradient(linear, 0 0, 0 100%, from(#ee5f5b), to(#c43c35)); + background-image: -webkit-linear-gradient(top, #ee5f5b, #c43c35); + background-image: -o-linear-gradient(top, #ee5f5b, #c43c35); + background-image: linear-gradient(to bottom, #ee5f5b, #c43c35); + background-repeat: repeat-x; + filter: progid:DXImageTransform.Microsoft.gradient(startColorstr='#ffee5f5b', endColorstr='#ffc43c35', GradientType=0); +} + +.progress-danger.progress-striped .bar, +.progress-striped .bar-danger { + background-color: #ee5f5b; + background-image: -webkit-gradient(linear, 0 100%, 100% 0, color-stop(0.25, rgba(255, 255, 255, 0.15)), color-stop(0.25, transparent), color-stop(0.5, transparent), color-stop(0.5, rgba(255, 255, 255, 0.15)), color-stop(0.75, rgba(255, 255, 255, 0.15)), color-stop(0.75, transparent), to(transparent)); + background-image: -webkit-linear-gradient(45deg, rgba(255, 255, 255, 0.15) 25%, transparent 25%, transparent 50%, rgba(255, 255, 255, 0.15) 50%, rgba(255, 255, 255, 0.15) 75%, transparent 75%, transparent); + background-image: -moz-linear-gradient(45deg, rgba(255, 255, 255, 0.15) 25%, transparent 25%, transparent 50%, rgba(255, 255, 255, 0.15) 50%, rgba(255, 255, 255, 0.15) 75%, transparent 75%, transparent); + background-image: -o-linear-gradient(45deg, rgba(255, 255, 255, 0.15) 25%, transparent 25%, transparent 50%, rgba(255, 255, 255, 0.15) 50%, rgba(255, 255, 255, 0.15) 75%, transparent 75%, transparent); + background-image: linear-gradient(45deg, rgba(255, 255, 255, 0.15) 25%, transparent 25%, transparent 50%, rgba(255, 255, 255, 0.15) 50%, rgba(255, 255, 255, 0.15) 75%, transparent 75%, transparent); +} + +.progress-success .bar, +.progress .bar-success { + background-color: #5eb95e; + background-image: -moz-linear-gradient(top, #62c462, #57a957); + background-image: -webkit-gradient(linear, 0 0, 0 100%, from(#62c462), to(#57a957)); + background-image: -webkit-linear-gradient(top, #62c462, #57a957); + background-image: -o-linear-gradient(top, #62c462, #57a957); + background-image: linear-gradient(to bottom, #62c462, #57a957); + background-repeat: repeat-x; + filter: progid:DXImageTransform.Microsoft.gradient(startColorstr='#ff62c462', endColorstr='#ff57a957', GradientType=0); +} + +.progress-success.progress-striped .bar, +.progress-striped .bar-success { + background-color: #62c462; + background-image: -webkit-gradient(linear, 0 100%, 100% 0, color-stop(0.25, rgba(255, 255, 255, 0.15)), color-stop(0.25, transparent), color-stop(0.5, transparent), color-stop(0.5, rgba(255, 255, 255, 0.15)), color-stop(0.75, rgba(255, 255, 255, 0.15)), color-stop(0.75, transparent), to(transparent)); + background-image: -webkit-linear-gradient(45deg, rgba(255, 255, 255, 0.15) 25%, transparent 25%, transparent 50%, rgba(255, 255, 255, 0.15) 50%, rgba(255, 255, 255, 0.15) 75%, transparent 75%, transparent); + background-image: -moz-linear-gradient(45deg, rgba(255, 255, 255, 0.15) 25%, transparent 25%, transparent 50%, rgba(255, 255, 255, 0.15) 50%, rgba(255, 255, 255, 0.15) 75%, transparent 75%, transparent); + background-image: -o-linear-gradient(45deg, rgba(255, 255, 255, 0.15) 25%, transparent 25%, transparent 50%, rgba(255, 255, 255, 0.15) 50%, rgba(255, 255, 255, 0.15) 75%, transparent 75%, transparent); + background-image: linear-gradient(45deg, rgba(255, 255, 255, 0.15) 25%, transparent 25%, transparent 50%, rgba(255, 255, 255, 0.15) 50%, rgba(255, 255, 255, 0.15) 75%, transparent 75%, transparent); +} + +.progress-info .bar, +.progress .bar-info { + background-color: #4bb1cf; + background-image: -moz-linear-gradient(top, #5bc0de, #339bb9); + background-image: -webkit-gradient(linear, 0 0, 0 100%, from(#5bc0de), to(#339bb9)); + background-image: -webkit-linear-gradient(top, #5bc0de, #339bb9); + background-image: -o-linear-gradient(top, #5bc0de, #339bb9); + background-image: linear-gradient(to bottom, #5bc0de, #339bb9); + background-repeat: repeat-x; + filter: progid:DXImageTransform.Microsoft.gradient(startColorstr='#ff5bc0de', endColorstr='#ff339bb9', GradientType=0); +} + +.progress-info.progress-striped .bar, +.progress-striped .bar-info { + background-color: #5bc0de; + background-image: -webkit-gradient(linear, 0 100%, 100% 0, color-stop(0.25, rgba(255, 255, 255, 0.15)), color-stop(0.25, transparent), color-stop(0.5, transparent), color-stop(0.5, rgba(255, 255, 255, 0.15)), color-stop(0.75, rgba(255, 255, 255, 0.15)), color-stop(0.75, transparent), to(transparent)); + background-image: -webkit-linear-gradient(45deg, rgba(255, 255, 255, 0.15) 25%, transparent 25%, transparent 50%, rgba(255, 255, 255, 0.15) 50%, rgba(255, 255, 255, 0.15) 75%, transparent 75%, transparent); + background-image: -moz-linear-gradient(45deg, rgba(255, 255, 255, 0.15) 25%, transparent 25%, transparent 50%, rgba(255, 255, 255, 0.15) 50%, rgba(255, 255, 255, 0.15) 75%, transparent 75%, transparent); + background-image: -o-linear-gradient(45deg, rgba(255, 255, 255, 0.15) 25%, transparent 25%, transparent 50%, rgba(255, 255, 255, 0.15) 50%, rgba(255, 255, 255, 0.15) 75%, transparent 75%, transparent); + background-image: linear-gradient(45deg, rgba(255, 255, 255, 0.15) 25%, transparent 25%, transparent 50%, rgba(255, 255, 255, 0.15) 50%, rgba(255, 255, 255, 0.15) 75%, transparent 75%, transparent); +} + +.progress-warning .bar, +.progress .bar-warning { + background-color: #faa732; + background-image: -moz-linear-gradient(top, #fbb450, #f89406); + background-image: -webkit-gradient(linear, 0 0, 0 100%, from(#fbb450), to(#f89406)); + background-image: -webkit-linear-gradient(top, #fbb450, #f89406); + background-image: -o-linear-gradient(top, #fbb450, #f89406); + background-image: linear-gradient(to bottom, #fbb450, #f89406); + background-repeat: repeat-x; + filter: progid:DXImageTransform.Microsoft.gradient(startColorstr='#fffbb450', endColorstr='#fff89406', GradientType=0); +} + +.progress-warning.progress-striped .bar, +.progress-striped .bar-warning { + background-color: #fbb450; + background-image: -webkit-gradient(linear, 0 100%, 100% 0, color-stop(0.25, rgba(255, 255, 255, 0.15)), color-stop(0.25, transparent), color-stop(0.5, transparent), color-stop(0.5, rgba(255, 255, 255, 0.15)), color-stop(0.75, rgba(255, 255, 255, 0.15)), color-stop(0.75, transparent), to(transparent)); + background-image: -webkit-linear-gradient(45deg, rgba(255, 255, 255, 0.15) 25%, transparent 25%, transparent 50%, rgba(255, 255, 255, 0.15) 50%, rgba(255, 255, 255, 0.15) 75%, transparent 75%, transparent); + background-image: -moz-linear-gradient(45deg, rgba(255, 255, 255, 0.15) 25%, transparent 25%, transparent 50%, rgba(255, 255, 255, 0.15) 50%, rgba(255, 255, 255, 0.15) 75%, transparent 75%, transparent); + background-image: -o-linear-gradient(45deg, rgba(255, 255, 255, 0.15) 25%, transparent 25%, transparent 50%, rgba(255, 255, 255, 0.15) 50%, rgba(255, 255, 255, 0.15) 75%, transparent 75%, transparent); + background-image: linear-gradient(45deg, rgba(255, 255, 255, 0.15) 25%, transparent 25%, transparent 50%, rgba(255, 255, 255, 0.15) 50%, rgba(255, 255, 255, 0.15) 75%, transparent 75%, transparent); +} + +.accordion { + margin-bottom: 20px; +} + +.accordion-group { + margin-bottom: 2px; + border: 1px solid #e5e5e5; + -webkit-border-radius: 4px; + -moz-border-radius: 4px; + border-radius: 4px; +} + +.accordion-heading { + border-bottom: 0; +} + +.accordion-heading .accordion-toggle { + display: block; + padding: 8px 15px; +} + +.accordion-toggle { + cursor: pointer; +} + +.accordion-inner { + padding: 9px 15px; + border-top: 1px solid #e5e5e5; +} + +.carousel { + position: relative; + margin-bottom: 20px; + line-height: 1; +} + +.carousel-inner { + position: relative; + width: 100%; + overflow: hidden; +} + +.carousel-inner > .item { + position: relative; + display: none; + -webkit-transition: 0.6s ease-in-out left; + -moz-transition: 0.6s ease-in-out left; + -o-transition: 0.6s ease-in-out left; + transition: 0.6s ease-in-out left; +} + +.carousel-inner > .item > img { + display: block; + line-height: 1; +} + +.carousel-inner > .active, +.carousel-inner > .next, +.carousel-inner > .prev { + display: block; +} + +.carousel-inner > .active { + left: 0; +} + +.carousel-inner > .next, +.carousel-inner > .prev { + position: absolute; + top: 0; + width: 100%; +} + +.carousel-inner > .next { + left: 100%; +} + +.carousel-inner > .prev { + left: -100%; +} + +.carousel-inner > .next.left, +.carousel-inner > .prev.right { + left: 0; +} + +.carousel-inner > .active.left { + left: -100%; +} + +.carousel-inner > .active.right { + left: 100%; +} + +.carousel-control { + position: absolute; + top: 40%; + left: 15px; + width: 40px; + height: 40px; + margin-top: -20px; + font-size: 60px; + font-weight: 100; + line-height: 30px; + color: #ffffff; + text-align: center; + background: #222222; + border: 3px solid #ffffff; + -webkit-border-radius: 23px; + -moz-border-radius: 23px; + border-radius: 23px; + opacity: 0.5; + filter: alpha(opacity=50); +} + +.carousel-control.right { + right: 15px; + left: auto; +} + +.carousel-control:hover { + color: #ffffff; + text-decoration: none; + opacity: 0.9; + filter: alpha(opacity=90); +} + +.carousel-caption { + position: absolute; + right: 0; + bottom: 0; + left: 0; + padding: 15px; + background: #333333; + background: rgba(0, 0, 0, 0.75); +} + +.carousel-caption h4, +.carousel-caption p { + line-height: 20px; + color: #ffffff; +} + +.carousel-caption h4 { + margin: 0 0 5px; +} + +.carousel-caption p { + margin-bottom: 0; +} + +.hero-unit { + padding: 60px; + margin-bottom: 30px; + font-size: 18px; + font-weight: 200; + line-height: 30px; + color: inherit; + background-color: #eeeeee; + -webkit-border-radius: 6px; + -moz-border-radius: 6px; + border-radius: 6px; +} + +.hero-unit h1 { + margin-bottom: 0; + font-size: 60px; + line-height: 1; + letter-spacing: -1px; + color: inherit; +} + +.hero-unit li { + line-height: 30px; +} + +.pull-right { + float: right; +} + +.pull-left { + float: left; +} + +.hide { + display: none; +} + +.show { + display: block; +} + +.invisible { + visibility: hidden; +} + +.affix { + position: fixed; +} diff --git a/website/css/bootstrap.min.css b/website/css/bootstrap.min.css new file mode 100644 index 00000000..140f731d --- /dev/null +++ b/website/css/bootstrap.min.css @@ -0,0 +1,9 @@ +/*! + * Bootstrap v2.2.2 + * + * Copyright 2012 Twitter, Inc + * Licensed under the Apache License v2.0 + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Designed and built with all the love in the world @twitter by @mdo and @fat. + */article,aside,details,figcaption,figure,footer,header,hgroup,nav,section{display:block}audio,canvas,video{display:inline-block;*display:inline;*zoom:1}audio:not([controls]){display:none}html{font-size:100%;-webkit-text-size-adjust:100%;-ms-text-size-adjust:100%}a:focus{outline:thin dotted #333;outline:5px auto -webkit-focus-ring-color;outline-offset:-2px}a:hover,a:active{outline:0}sub,sup{position:relative;font-size:75%;line-height:0;vertical-align:baseline}sup{top:-0.5em}sub{bottom:-0.25em}img{width:auto\9;height:auto;max-width:100%;vertical-align:middle;border:0;-ms-interpolation-mode:bicubic}#map_canvas img,.google-maps img{max-width:none}button,input,select,textarea{margin:0;font-size:100%;vertical-align:middle}button,input{*overflow:visible;line-height:normal}button::-moz-focus-inner,input::-moz-focus-inner{padding:0;border:0}button,html input[type="button"],input[type="reset"],input[type="submit"]{cursor:pointer;-webkit-appearance:button}label,select,button,input[type="button"],input[type="reset"],input[type="submit"],input[type="radio"],input[type="checkbox"]{cursor:pointer}input[type="search"]{-webkit-box-sizing:content-box;-moz-box-sizing:content-box;box-sizing:content-box;-webkit-appearance:textfield}input[type="search"]::-webkit-search-decoration,input[type="search"]::-webkit-search-cancel-button{-webkit-appearance:none}textarea{overflow:auto;vertical-align:top}@media print{*{color:#000!important;text-shadow:none!important;background:transparent!important;box-shadow:none!important}a,a:visited{text-decoration:underline}a[href]:after{content:" (" attr(href) ")"}abbr[title]:after{content:" (" attr(title) ")"}.ir a:after,a[href^="javascript:"]:after,a[href^="#"]:after{content:""}pre,blockquote{border:1px solid #999;page-break-inside:avoid}thead{display:table-header-group}tr,img{page-break-inside:avoid}img{max-width:100%!important}@page{margin:.5cm}p,h2,h3{orphans:3;widows:3}h2,h3{page-break-after:avoid}}.clearfix{*zoom:1}.clearfix:before,.clearfix:after{display:table;line-height:0;content:""}.clearfix:after{clear:both}.hide-text{font:0/0 a;color:transparent;text-shadow:none;background-color:transparent;border:0}.input-block-level{display:block;width:100%;min-height:30px;-webkit-box-sizing:border-box;-moz-box-sizing:border-box;box-sizing:border-box}body{margin:0;font-family:"Helvetica Neue",Helvetica,Arial,sans-serif;font-size:14px;line-height:20px;color:#333;background-color:#fff}a{color:#08c;text-decoration:none}a:hover{color:#005580;text-decoration:underline}.img-rounded{-webkit-border-radius:6px;-moz-border-radius:6px;border-radius:6px}.img-polaroid{padding:4px;background-color:#fff;border:1px solid #ccc;border:1px solid rgba(0,0,0,0.2);-webkit-box-shadow:0 1px 3px rgba(0,0,0,0.1);-moz-box-shadow:0 1px 3px rgba(0,0,0,0.1);box-shadow:0 1px 3px rgba(0,0,0,0.1)}.img-circle{-webkit-border-radius:500px;-moz-border-radius:500px;border-radius:500px}.row{margin-left:-20px;*zoom:1}.row:before,.row:after{display:table;line-height:0;content:""}.row:after{clear:both}[class*="span"]{float:left;min-height:1px;margin-left:20px}.container,.navbar-static-top .container,.navbar-fixed-top .container,.navbar-fixed-bottom .container{width:940px}.span12{width:940px}.span11{width:860px}.span10{width:780px}.span9{width:700px}.span8{width:620px}.span7{width:540px}.span6{width:460px}.span5{width:380px}.span4{width:300px}.span3{width:220px}.span2{width:140px}.span1{width:60px}.offset12{margin-left:980px}.offset11{margin-left:900px}.offset10{margin-left:820px}.offset9{margin-left:740px}.offset8{margin-left:660px}.offset7{margin-left:580px}.offset6{margin-left:500px}.offset5{margin-left:420px}.offset4{margin-left:340px}.offset3{margin-left:260px}.offset2{margin-left:180px}.offset1{margin-left:100px}.row-fluid{width:100%;*zoom:1}.row-fluid:before,.row-fluid:after{display:table;line-height:0;content:""}.row-fluid:after{clear:both}.row-fluid [class*="span"]{display:block;float:left;width:100%;min-height:30px;margin-left:2.127659574468085%;*margin-left:2.074468085106383%;-webkit-box-sizing:border-box;-moz-box-sizing:border-box;box-sizing:border-box}.row-fluid [class*="span"]:first-child{margin-left:0}.row-fluid .controls-row [class*="span"]+[class*="span"]{margin-left:2.127659574468085%}.row-fluid .span12{width:100%;*width:99.94680851063829%}.row-fluid .span11{width:91.48936170212765%;*width:91.43617021276594%}.row-fluid .span10{width:82.97872340425532%;*width:82.92553191489361%}.row-fluid .span9{width:74.46808510638297%;*width:74.41489361702126%}.row-fluid .span8{width:65.95744680851064%;*width:65.90425531914893%}.row-fluid .span7{width:57.44680851063829%;*width:57.39361702127659%}.row-fluid .span6{width:48.93617021276595%;*width:48.88297872340425%}.row-fluid .span5{width:40.42553191489362%;*width:40.37234042553192%}.row-fluid .span4{width:31.914893617021278%;*width:31.861702127659576%}.row-fluid .span3{width:23.404255319148934%;*width:23.351063829787233%}.row-fluid .span2{width:14.893617021276595%;*width:14.840425531914894%}.row-fluid .span1{width:6.382978723404255%;*width:6.329787234042553%}.row-fluid .offset12{margin-left:104.25531914893617%;*margin-left:104.14893617021275%}.row-fluid .offset12:first-child{margin-left:102.12765957446808%;*margin-left:102.02127659574467%}.row-fluid .offset11{margin-left:95.74468085106382%;*margin-left:95.6382978723404%}.row-fluid .offset11:first-child{margin-left:93.61702127659574%;*margin-left:93.51063829787232%}.row-fluid .offset10{margin-left:87.23404255319149%;*margin-left:87.12765957446807%}.row-fluid .offset10:first-child{margin-left:85.1063829787234%;*margin-left:84.99999999999999%}.row-fluid .offset9{margin-left:78.72340425531914%;*margin-left:78.61702127659572%}.row-fluid .offset9:first-child{margin-left:76.59574468085106%;*margin-left:76.48936170212764%}.row-fluid .offset8{margin-left:70.2127659574468%;*margin-left:70.10638297872339%}.row-fluid .offset8:first-child{margin-left:68.08510638297872%;*margin-left:67.9787234042553%}.row-fluid .offset7{margin-left:61.70212765957446%;*margin-left:61.59574468085106%}.row-fluid .offset7:first-child{margin-left:59.574468085106375%;*margin-left:59.46808510638297%}.row-fluid .offset6{margin-left:53.191489361702125%;*margin-left:53.085106382978715%}.row-fluid .offset6:first-child{margin-left:51.063829787234035%;*margin-left:50.95744680851063%}.row-fluid .offset5{margin-left:44.68085106382979%;*margin-left:44.57446808510638%}.row-fluid .offset5:first-child{margin-left:42.5531914893617%;*margin-left:42.4468085106383%}.row-fluid .offset4{margin-left:36.170212765957444%;*margin-left:36.06382978723405%}.row-fluid .offset4:first-child{margin-left:34.04255319148936%;*margin-left:33.93617021276596%}.row-fluid .offset3{margin-left:27.659574468085104%;*margin-left:27.5531914893617%}.row-fluid .offset3:first-child{margin-left:25.53191489361702%;*margin-left:25.425531914893618%}.row-fluid .offset2{margin-left:19.148936170212764%;*margin-left:19.04255319148936%}.row-fluid .offset2:first-child{margin-left:17.02127659574468%;*margin-left:16.914893617021278%}.row-fluid .offset1{margin-left:10.638297872340425%;*margin-left:10.53191489361702%}.row-fluid .offset1:first-child{margin-left:8.51063829787234%;*margin-left:8.404255319148938%}[class*="span"].hide,.row-fluid [class*="span"].hide{display:none}[class*="span"].pull-right,.row-fluid [class*="span"].pull-right{float:right}.container{margin-right:auto;margin-left:auto;*zoom:1}.container:before,.container:after{display:table;line-height:0;content:""}.container:after{clear:both}.container-fluid{padding-right:20px;padding-left:20px;*zoom:1}.container-fluid:before,.container-fluid:after{display:table;line-height:0;content:""}.container-fluid:after{clear:both}p{margin:0 0 10px}.lead{margin-bottom:20px;font-size:21px;font-weight:200;line-height:30px}small{font-size:85%}strong{font-weight:bold}em{font-style:italic}cite{font-style:normal}.muted{color:#999}a.muted:hover{color:#808080}.text-warning{color:#c09853}a.text-warning:hover{color:#a47e3c}.text-error{color:#b94a48}a.text-error:hover{color:#953b39}.text-info{color:#3a87ad}a.text-info:hover{color:#2d6987}.text-success{color:#468847}a.text-success:hover{color:#356635}h1,h2,h3,h4,h5,h6{margin:10px 0;font-family:inherit;font-weight:bold;line-height:20px;color:inherit;text-rendering:optimizelegibility}h1 small,h2 small,h3 small,h4 small,h5 small,h6 small{font-weight:normal;line-height:1;color:#999}h1,h2,h3{line-height:40px}h1{font-size:38.5px}h2{font-size:31.5px}h3{font-size:24.5px}h4{font-size:17.5px}h5{font-size:14px}h6{font-size:11.9px}h1 small{font-size:24.5px}h2 small{font-size:17.5px}h3 small{font-size:14px}h4 small{font-size:14px}.page-header{padding-bottom:9px;margin:20px 0 30px;border-bottom:1px solid #eee}ul,ol{padding:0;margin:0 0 10px 25px}ul ul,ul ol,ol ol,ol ul{margin-bottom:0}li{line-height:20px}ul.unstyled,ol.unstyled{margin-left:0;list-style:none}ul.inline,ol.inline{margin-left:0;list-style:none}ul.inline>li,ol.inline>li{display:inline-block;padding-right:5px;padding-left:5px}dl{margin-bottom:20px}dt,dd{line-height:20px}dt{font-weight:bold}dd{margin-left:10px}.dl-horizontal{*zoom:1}.dl-horizontal:before,.dl-horizontal:after{display:table;line-height:0;content:""}.dl-horizontal:after{clear:both}.dl-horizontal dt{float:left;width:160px;overflow:hidden;clear:left;text-align:right;text-overflow:ellipsis;white-space:nowrap}.dl-horizontal dd{margin-left:180px}hr{margin:20px 0;border:0;border-top:1px solid #eee;border-bottom:1px solid #fff}abbr[title],abbr[data-original-title]{cursor:help;border-bottom:1px dotted #999}abbr.initialism{font-size:90%;text-transform:uppercase}blockquote{padding:0 0 0 15px;margin:0 0 20px;border-left:5px solid #eee}blockquote p{margin-bottom:0;font-size:16px;font-weight:300;line-height:25px}blockquote small{display:block;line-height:20px;color:#999}blockquote small:before{content:'\2014 \00A0'}blockquote.pull-right{float:right;padding-right:15px;padding-left:0;border-right:5px solid #eee;border-left:0}blockquote.pull-right p,blockquote.pull-right small{text-align:right}blockquote.pull-right small:before{content:''}blockquote.pull-right small:after{content:'\00A0 \2014'}q:before,q:after,blockquote:before,blockquote:after{content:""}address{display:block;margin-bottom:20px;font-style:normal;line-height:20px}code,pre{padding:0 3px 2px;font-family:Monaco,Menlo,Consolas,"Courier New",monospace;font-size:12px;color:#333;-webkit-border-radius:3px;-moz-border-radius:3px;border-radius:3px}code{padding:2px 4px;color:#d14;white-space:nowrap;background-color:#f7f7f9;border:1px solid #e1e1e8}pre{display:block;padding:9.5px;margin:0 0 10px;font-size:13px;line-height:20px;word-break:break-all;word-wrap:break-word;white-space:pre;white-space:pre-wrap;background-color:#f5f5f5;border:1px solid #ccc;border:1px solid rgba(0,0,0,0.15);-webkit-border-radius:4px;-moz-border-radius:4px;border-radius:4px}pre.prettyprint{margin-bottom:20px}pre code{padding:0;color:inherit;white-space:pre;white-space:pre-wrap;background-color:transparent;border:0}.pre-scrollable{max-height:340px;overflow-y:scroll}form{margin:0 0 20px}fieldset{padding:0;margin:0;border:0}legend{display:block;width:100%;padding:0;margin-bottom:20px;font-size:21px;line-height:40px;color:#333;border:0;border-bottom:1px solid #e5e5e5}legend small{font-size:15px;color:#999}label,input,button,select,textarea{font-size:14px;font-weight:normal;line-height:20px}input,button,select,textarea{font-family:"Helvetica Neue",Helvetica,Arial,sans-serif}label{display:block;margin-bottom:5px}select,textarea,input[type="text"],input[type="password"],input[type="datetime"],input[type="datetime-local"],input[type="date"],input[type="month"],input[type="time"],input[type="week"],input[type="number"],input[type="email"],input[type="url"],input[type="search"],input[type="tel"],input[type="color"],.uneditable-input{display:inline-block;height:20px;padding:4px 6px;margin-bottom:10px;font-size:14px;line-height:20px;color:#555;vertical-align:middle;-webkit-border-radius:4px;-moz-border-radius:4px;border-radius:4px}input,textarea,.uneditable-input{width:206px}textarea{height:auto}textarea,input[type="text"],input[type="password"],input[type="datetime"],input[type="datetime-local"],input[type="date"],input[type="month"],input[type="time"],input[type="week"],input[type="number"],input[type="email"],input[type="url"],input[type="search"],input[type="tel"],input[type="color"],.uneditable-input{background-color:#fff;border:1px solid #ccc;-webkit-box-shadow:inset 0 1px 1px rgba(0,0,0,0.075);-moz-box-shadow:inset 0 1px 1px rgba(0,0,0,0.075);box-shadow:inset 0 1px 1px rgba(0,0,0,0.075);-webkit-transition:border linear .2s,box-shadow linear .2s;-moz-transition:border linear .2s,box-shadow linear .2s;-o-transition:border linear .2s,box-shadow linear .2s;transition:border linear .2s,box-shadow linear .2s}textarea:focus,input[type="text"]:focus,input[type="password"]:focus,input[type="datetime"]:focus,input[type="datetime-local"]:focus,input[type="date"]:focus,input[type="month"]:focus,input[type="time"]:focus,input[type="week"]:focus,input[type="number"]:focus,input[type="email"]:focus,input[type="url"]:focus,input[type="search"]:focus,input[type="tel"]:focus,input[type="color"]:focus,.uneditable-input:focus{border-color:rgba(82,168,236,0.8);outline:0;outline:thin dotted \9;-webkit-box-shadow:inset 0 1px 1px rgba(0,0,0,0.075),0 0 8px rgba(82,168,236,0.6);-moz-box-shadow:inset 0 1px 1px rgba(0,0,0,0.075),0 0 8px rgba(82,168,236,0.6);box-shadow:inset 0 1px 1px rgba(0,0,0,0.075),0 0 8px rgba(82,168,236,0.6)}input[type="radio"],input[type="checkbox"]{margin:4px 0 0;margin-top:1px \9;*margin-top:0;line-height:normal}input[type="file"],input[type="image"],input[type="submit"],input[type="reset"],input[type="button"],input[type="radio"],input[type="checkbox"]{width:auto}select,input[type="file"]{height:30px;*margin-top:4px;line-height:30px}select{width:220px;background-color:#fff;border:1px solid #ccc}select[multiple],select[size]{height:auto}select:focus,input[type="file"]:focus,input[type="radio"]:focus,input[type="checkbox"]:focus{outline:thin dotted #333;outline:5px auto -webkit-focus-ring-color;outline-offset:-2px}.uneditable-input,.uneditable-textarea{color:#999;cursor:not-allowed;background-color:#fcfcfc;border-color:#ccc;-webkit-box-shadow:inset 0 1px 2px rgba(0,0,0,0.025);-moz-box-shadow:inset 0 1px 2px rgba(0,0,0,0.025);box-shadow:inset 0 1px 2px rgba(0,0,0,0.025)}.uneditable-input{overflow:hidden;white-space:nowrap}.uneditable-textarea{width:auto;height:auto}input:-moz-placeholder,textarea:-moz-placeholder{color:#999}input:-ms-input-placeholder,textarea:-ms-input-placeholder{color:#999}input::-webkit-input-placeholder,textarea::-webkit-input-placeholder{color:#999}.radio,.checkbox{min-height:20px;padding-left:20px}.radio input[type="radio"],.checkbox input[type="checkbox"]{float:left;margin-left:-20px}.controls>.radio:first-child,.controls>.checkbox:first-child{padding-top:5px}.radio.inline,.checkbox.inline{display:inline-block;padding-top:5px;margin-bottom:0;vertical-align:middle}.radio.inline+.radio.inline,.checkbox.inline+.checkbox.inline{margin-left:10px}.input-mini{width:60px}.input-small{width:90px}.input-medium{width:150px}.input-large{width:210px}.input-xlarge{width:270px}.input-xxlarge{width:530px}input[class*="span"],select[class*="span"],textarea[class*="span"],.uneditable-input[class*="span"],.row-fluid input[class*="span"],.row-fluid select[class*="span"],.row-fluid textarea[class*="span"],.row-fluid .uneditable-input[class*="span"]{float:none;margin-left:0}.input-append input[class*="span"],.input-append .uneditable-input[class*="span"],.input-prepend input[class*="span"],.input-prepend .uneditable-input[class*="span"],.row-fluid input[class*="span"],.row-fluid select[class*="span"],.row-fluid textarea[class*="span"],.row-fluid .uneditable-input[class*="span"],.row-fluid .input-prepend [class*="span"],.row-fluid .input-append [class*="span"]{display:inline-block}input,textarea,.uneditable-input{margin-left:0}.controls-row [class*="span"]+[class*="span"]{margin-left:20px}input.span12,textarea.span12,.uneditable-input.span12{width:926px}input.span11,textarea.span11,.uneditable-input.span11{width:846px}input.span10,textarea.span10,.uneditable-input.span10{width:766px}input.span9,textarea.span9,.uneditable-input.span9{width:686px}input.span8,textarea.span8,.uneditable-input.span8{width:606px}input.span7,textarea.span7,.uneditable-input.span7{width:526px}input.span6,textarea.span6,.uneditable-input.span6{width:446px}input.span5,textarea.span5,.uneditable-input.span5{width:366px}input.span4,textarea.span4,.uneditable-input.span4{width:286px}input.span3,textarea.span3,.uneditable-input.span3{width:206px}input.span2,textarea.span2,.uneditable-input.span2{width:126px}input.span1,textarea.span1,.uneditable-input.span1{width:46px}.controls-row{*zoom:1}.controls-row:before,.controls-row:after{display:table;line-height:0;content:""}.controls-row:after{clear:both}.controls-row [class*="span"],.row-fluid .controls-row [class*="span"]{float:left}.controls-row .checkbox[class*="span"],.controls-row .radio[class*="span"]{padding-top:5px}input[disabled],select[disabled],textarea[disabled],input[readonly],select[readonly],textarea[readonly]{cursor:not-allowed;background-color:#eee}input[type="radio"][disabled],input[type="checkbox"][disabled],input[type="radio"][readonly],input[type="checkbox"][readonly]{background-color:transparent}.control-group.warning .control-label,.control-group.warning .help-block,.control-group.warning .help-inline{color:#c09853}.control-group.warning .checkbox,.control-group.warning .radio,.control-group.warning input,.control-group.warning select,.control-group.warning textarea{color:#c09853}.control-group.warning input,.control-group.warning select,.control-group.warning textarea{border-color:#c09853;-webkit-box-shadow:inset 0 1px 1px rgba(0,0,0,0.075);-moz-box-shadow:inset 0 1px 1px rgba(0,0,0,0.075);box-shadow:inset 0 1px 1px rgba(0,0,0,0.075)}.control-group.warning input:focus,.control-group.warning select:focus,.control-group.warning textarea:focus{border-color:#a47e3c;-webkit-box-shadow:inset 0 1px 1px rgba(0,0,0,0.075),0 0 6px #dbc59e;-moz-box-shadow:inset 0 1px 1px rgba(0,0,0,0.075),0 0 6px #dbc59e;box-shadow:inset 0 1px 1px rgba(0,0,0,0.075),0 0 6px #dbc59e}.control-group.warning .input-prepend .add-on,.control-group.warning .input-append .add-on{color:#c09853;background-color:#fcf8e3;border-color:#c09853}.control-group.error .control-label,.control-group.error .help-block,.control-group.error .help-inline{color:#b94a48}.control-group.error .checkbox,.control-group.error .radio,.control-group.error input,.control-group.error select,.control-group.error textarea{color:#b94a48}.control-group.error input,.control-group.error select,.control-group.error textarea{border-color:#b94a48;-webkit-box-shadow:inset 0 1px 1px rgba(0,0,0,0.075);-moz-box-shadow:inset 0 1px 1px rgba(0,0,0,0.075);box-shadow:inset 0 1px 1px rgba(0,0,0,0.075)}.control-group.error input:focus,.control-group.error select:focus,.control-group.error textarea:focus{border-color:#953b39;-webkit-box-shadow:inset 0 1px 1px rgba(0,0,0,0.075),0 0 6px #d59392;-moz-box-shadow:inset 0 1px 1px rgba(0,0,0,0.075),0 0 6px #d59392;box-shadow:inset 0 1px 1px rgba(0,0,0,0.075),0 0 6px #d59392}.control-group.error .input-prepend .add-on,.control-group.error .input-append .add-on{color:#b94a48;background-color:#f2dede;border-color:#b94a48}.control-group.success .control-label,.control-group.success .help-block,.control-group.success .help-inline{color:#468847}.control-group.success .checkbox,.control-group.success .radio,.control-group.success input,.control-group.success select,.control-group.success textarea{color:#468847}.control-group.success input,.control-group.success select,.control-group.success textarea{border-color:#468847;-webkit-box-shadow:inset 0 1px 1px rgba(0,0,0,0.075);-moz-box-shadow:inset 0 1px 1px rgba(0,0,0,0.075);box-shadow:inset 0 1px 1px rgba(0,0,0,0.075)}.control-group.success input:focus,.control-group.success select:focus,.control-group.success textarea:focus{border-color:#356635;-webkit-box-shadow:inset 0 1px 1px rgba(0,0,0,0.075),0 0 6px #7aba7b;-moz-box-shadow:inset 0 1px 1px rgba(0,0,0,0.075),0 0 6px #7aba7b;box-shadow:inset 0 1px 1px rgba(0,0,0,0.075),0 0 6px #7aba7b}.control-group.success .input-prepend .add-on,.control-group.success .input-append .add-on{color:#468847;background-color:#dff0d8;border-color:#468847}.control-group.info .control-label,.control-group.info .help-block,.control-group.info .help-inline{color:#3a87ad}.control-group.info .checkbox,.control-group.info .radio,.control-group.info input,.control-group.info select,.control-group.info textarea{color:#3a87ad}.control-group.info input,.control-group.info select,.control-group.info textarea{border-color:#3a87ad;-webkit-box-shadow:inset 0 1px 1px rgba(0,0,0,0.075);-moz-box-shadow:inset 0 1px 1px rgba(0,0,0,0.075);box-shadow:inset 0 1px 1px rgba(0,0,0,0.075)}.control-group.info input:focus,.control-group.info select:focus,.control-group.info textarea:focus{border-color:#2d6987;-webkit-box-shadow:inset 0 1px 1px rgba(0,0,0,0.075),0 0 6px #7ab5d3;-moz-box-shadow:inset 0 1px 1px rgba(0,0,0,0.075),0 0 6px #7ab5d3;box-shadow:inset 0 1px 1px rgba(0,0,0,0.075),0 0 6px #7ab5d3}.control-group.info .input-prepend .add-on,.control-group.info .input-append .add-on{color:#3a87ad;background-color:#d9edf7;border-color:#3a87ad}input:focus:invalid,textarea:focus:invalid,select:focus:invalid{color:#b94a48;border-color:#ee5f5b}input:focus:invalid:focus,textarea:focus:invalid:focus,select:focus:invalid:focus{border-color:#e9322d;-webkit-box-shadow:0 0 6px #f8b9b7;-moz-box-shadow:0 0 6px #f8b9b7;box-shadow:0 0 6px #f8b9b7}.form-actions{padding:19px 20px 20px;margin-top:20px;margin-bottom:20px;background-color:#f5f5f5;border-top:1px solid #e5e5e5;*zoom:1}.form-actions:before,.form-actions:after{display:table;line-height:0;content:""}.form-actions:after{clear:both}.help-block,.help-inline{color:#595959}.help-block{display:block;margin-bottom:10px}.help-inline{display:inline-block;*display:inline;padding-left:5px;vertical-align:middle;*zoom:1}.input-append,.input-prepend{margin-bottom:5px;font-size:0;white-space:nowrap}.input-append input,.input-prepend input,.input-append select,.input-prepend select,.input-append .uneditable-input,.input-prepend .uneditable-input,.input-append .dropdown-menu,.input-prepend .dropdown-menu{font-size:14px}.input-append input,.input-prepend input,.input-append select,.input-prepend select,.input-append .uneditable-input,.input-prepend .uneditable-input{position:relative;margin-bottom:0;*margin-left:0;vertical-align:top;-webkit-border-radius:0 4px 4px 0;-moz-border-radius:0 4px 4px 0;border-radius:0 4px 4px 0}.input-append input:focus,.input-prepend input:focus,.input-append select:focus,.input-prepend select:focus,.input-append .uneditable-input:focus,.input-prepend .uneditable-input:focus{z-index:2}.input-append .add-on,.input-prepend .add-on{display:inline-block;width:auto;height:20px;min-width:16px;padding:4px 5px;font-size:14px;font-weight:normal;line-height:20px;text-align:center;text-shadow:0 1px 0 #fff;background-color:#eee;border:1px solid #ccc}.input-append .add-on,.input-prepend .add-on,.input-append .btn,.input-prepend .btn,.input-append .btn-group>.dropdown-toggle,.input-prepend .btn-group>.dropdown-toggle{vertical-align:top;-webkit-border-radius:0;-moz-border-radius:0;border-radius:0}.input-append .active,.input-prepend .active{background-color:#a9dba9;border-color:#46a546}.input-prepend .add-on,.input-prepend .btn{margin-right:-1px}.input-prepend .add-on:first-child,.input-prepend .btn:first-child{-webkit-border-radius:4px 0 0 4px;-moz-border-radius:4px 0 0 4px;border-radius:4px 0 0 4px}.input-append input,.input-append select,.input-append .uneditable-input{-webkit-border-radius:4px 0 0 4px;-moz-border-radius:4px 0 0 4px;border-radius:4px 0 0 4px}.input-append input+.btn-group .btn:last-child,.input-append select+.btn-group .btn:last-child,.input-append .uneditable-input+.btn-group .btn:last-child{-webkit-border-radius:0 4px 4px 0;-moz-border-radius:0 4px 4px 0;border-radius:0 4px 4px 0}.input-append .add-on,.input-append .btn,.input-append .btn-group{margin-left:-1px}.input-append .add-on:last-child,.input-append .btn:last-child,.input-append .btn-group:last-child>.dropdown-toggle{-webkit-border-radius:0 4px 4px 0;-moz-border-radius:0 4px 4px 0;border-radius:0 4px 4px 0}.input-prepend.input-append input,.input-prepend.input-append select,.input-prepend.input-append .uneditable-input{-webkit-border-radius:0;-moz-border-radius:0;border-radius:0}.input-prepend.input-append input+.btn-group .btn,.input-prepend.input-append select+.btn-group .btn,.input-prepend.input-append .uneditable-input+.btn-group .btn{-webkit-border-radius:0 4px 4px 0;-moz-border-radius:0 4px 4px 0;border-radius:0 4px 4px 0}.input-prepend.input-append .add-on:first-child,.input-prepend.input-append .btn:first-child{margin-right:-1px;-webkit-border-radius:4px 0 0 4px;-moz-border-radius:4px 0 0 4px;border-radius:4px 0 0 4px}.input-prepend.input-append .add-on:last-child,.input-prepend.input-append .btn:last-child{margin-left:-1px;-webkit-border-radius:0 4px 4px 0;-moz-border-radius:0 4px 4px 0;border-radius:0 4px 4px 0}.input-prepend.input-append .btn-group:first-child{margin-left:0}input.search-query{padding-right:14px;padding-right:4px \9;padding-left:14px;padding-left:4px \9;margin-bottom:0;-webkit-border-radius:15px;-moz-border-radius:15px;border-radius:15px}.form-search .input-append .search-query,.form-search .input-prepend .search-query{-webkit-border-radius:0;-moz-border-radius:0;border-radius:0}.form-search .input-append .search-query{-webkit-border-radius:14px 0 0 14px;-moz-border-radius:14px 0 0 14px;border-radius:14px 0 0 14px}.form-search .input-append .btn{-webkit-border-radius:0 14px 14px 0;-moz-border-radius:0 14px 14px 0;border-radius:0 14px 14px 0}.form-search .input-prepend .search-query{-webkit-border-radius:0 14px 14px 0;-moz-border-radius:0 14px 14px 0;border-radius:0 14px 14px 0}.form-search .input-prepend .btn{-webkit-border-radius:14px 0 0 14px;-moz-border-radius:14px 0 0 14px;border-radius:14px 0 0 14px}.form-search input,.form-inline input,.form-horizontal input,.form-search textarea,.form-inline textarea,.form-horizontal textarea,.form-search select,.form-inline select,.form-horizontal select,.form-search .help-inline,.form-inline .help-inline,.form-horizontal .help-inline,.form-search .uneditable-input,.form-inline .uneditable-input,.form-horizontal .uneditable-input,.form-search .input-prepend,.form-inline .input-prepend,.form-horizontal .input-prepend,.form-search .input-append,.form-inline .input-append,.form-horizontal .input-append{display:inline-block;*display:inline;margin-bottom:0;vertical-align:middle;*zoom:1}.form-search .hide,.form-inline .hide,.form-horizontal .hide{display:none}.form-search label,.form-inline label,.form-search .btn-group,.form-inline .btn-group{display:inline-block}.form-search .input-append,.form-inline .input-append,.form-search .input-prepend,.form-inline .input-prepend{margin-bottom:0}.form-search .radio,.form-search .checkbox,.form-inline .radio,.form-inline .checkbox{padding-left:0;margin-bottom:0;vertical-align:middle}.form-search .radio input[type="radio"],.form-search .checkbox input[type="checkbox"],.form-inline .radio input[type="radio"],.form-inline .checkbox input[type="checkbox"]{float:left;margin-right:3px;margin-left:0}.control-group{margin-bottom:10px}legend+.control-group{margin-top:20px;-webkit-margin-top-collapse:separate}.form-horizontal .control-group{margin-bottom:20px;*zoom:1}.form-horizontal .control-group:before,.form-horizontal .control-group:after{display:table;line-height:0;content:""}.form-horizontal .control-group:after{clear:both}.form-horizontal .control-label{float:left;width:160px;padding-top:5px;text-align:right}.form-horizontal .controls{*display:inline-block;*padding-left:20px;margin-left:180px;*margin-left:0}.form-horizontal .controls:first-child{*padding-left:180px}.form-horizontal .help-block{margin-bottom:0}.form-horizontal input+.help-block,.form-horizontal select+.help-block,.form-horizontal textarea+.help-block,.form-horizontal .uneditable-input+.help-block,.form-horizontal .input-prepend+.help-block,.form-horizontal .input-append+.help-block{margin-top:10px}.form-horizontal .form-actions{padding-left:180px}table{max-width:100%;background-color:transparent;border-collapse:collapse;border-spacing:0}.table{width:100%;margin-bottom:20px}.table th,.table td{padding:8px;line-height:20px;text-align:left;vertical-align:top;border-top:1px solid #ddd}.table th{font-weight:bold}.table thead th{vertical-align:bottom}.table caption+thead tr:first-child th,.table caption+thead tr:first-child td,.table colgroup+thead tr:first-child th,.table colgroup+thead tr:first-child td,.table thead:first-child tr:first-child th,.table thead:first-child tr:first-child td{border-top:0}.table tbody+tbody{border-top:2px solid #ddd}.table .table{background-color:#fff}.table-condensed th,.table-condensed td{padding:4px 5px}.table-bordered{border:1px solid #ddd;border-collapse:separate;*border-collapse:collapse;border-left:0;-webkit-border-radius:4px;-moz-border-radius:4px;border-radius:4px}.table-bordered th,.table-bordered td{border-left:1px solid #ddd}.table-bordered caption+thead tr:first-child th,.table-bordered caption+tbody tr:first-child th,.table-bordered caption+tbody tr:first-child td,.table-bordered colgroup+thead tr:first-child th,.table-bordered colgroup+tbody tr:first-child th,.table-bordered colgroup+tbody tr:first-child td,.table-bordered thead:first-child tr:first-child th,.table-bordered tbody:first-child tr:first-child th,.table-bordered tbody:first-child tr:first-child td{border-top:0}.table-bordered thead:first-child tr:first-child>th:first-child,.table-bordered tbody:first-child tr:first-child>td:first-child{-webkit-border-top-left-radius:4px;border-top-left-radius:4px;-moz-border-radius-topleft:4px}.table-bordered thead:first-child tr:first-child>th:last-child,.table-bordered tbody:first-child tr:first-child>td:last-child{-webkit-border-top-right-radius:4px;border-top-right-radius:4px;-moz-border-radius-topright:4px}.table-bordered thead:last-child tr:last-child>th:first-child,.table-bordered tbody:last-child tr:last-child>td:first-child,.table-bordered tfoot:last-child tr:last-child>td:first-child{-webkit-border-bottom-left-radius:4px;border-bottom-left-radius:4px;-moz-border-radius-bottomleft:4px}.table-bordered thead:last-child tr:last-child>th:last-child,.table-bordered tbody:last-child tr:last-child>td:last-child,.table-bordered tfoot:last-child tr:last-child>td:last-child{-webkit-border-bottom-right-radius:4px;border-bottom-right-radius:4px;-moz-border-radius-bottomright:4px}.table-bordered tfoot+tbody:last-child tr:last-child td:first-child{-webkit-border-bottom-left-radius:0;border-bottom-left-radius:0;-moz-border-radius-bottomleft:0}.table-bordered tfoot+tbody:last-child tr:last-child td:last-child{-webkit-border-bottom-right-radius:0;border-bottom-right-radius:0;-moz-border-radius-bottomright:0}.table-bordered caption+thead tr:first-child th:first-child,.table-bordered caption+tbody tr:first-child td:first-child,.table-bordered colgroup+thead tr:first-child th:first-child,.table-bordered colgroup+tbody tr:first-child td:first-child{-webkit-border-top-left-radius:4px;border-top-left-radius:4px;-moz-border-radius-topleft:4px}.table-bordered caption+thead tr:first-child th:last-child,.table-bordered caption+tbody tr:first-child td:last-child,.table-bordered colgroup+thead tr:first-child th:last-child,.table-bordered colgroup+tbody tr:first-child td:last-child{-webkit-border-top-right-radius:4px;border-top-right-radius:4px;-moz-border-radius-topright:4px}.table-striped tbody>tr:nth-child(odd)>td,.table-striped tbody>tr:nth-child(odd)>th{background-color:#f9f9f9}.table-hover tbody tr:hover td,.table-hover tbody tr:hover th{background-color:#f5f5f5}table td[class*="span"],table th[class*="span"],.row-fluid table td[class*="span"],.row-fluid table th[class*="span"]{display:table-cell;float:none;margin-left:0}.table td.span1,.table th.span1{float:none;width:44px;margin-left:0}.table td.span2,.table th.span2{float:none;width:124px;margin-left:0}.table td.span3,.table th.span3{float:none;width:204px;margin-left:0}.table td.span4,.table th.span4{float:none;width:284px;margin-left:0}.table td.span5,.table th.span5{float:none;width:364px;margin-left:0}.table td.span6,.table th.span6{float:none;width:444px;margin-left:0}.table td.span7,.table th.span7{float:none;width:524px;margin-left:0}.table td.span8,.table th.span8{float:none;width:604px;margin-left:0}.table td.span9,.table th.span9{float:none;width:684px;margin-left:0}.table td.span10,.table th.span10{float:none;width:764px;margin-left:0}.table td.span11,.table th.span11{float:none;width:844px;margin-left:0}.table td.span12,.table th.span12{float:none;width:924px;margin-left:0}.table tbody tr.success td{background-color:#dff0d8}.table tbody tr.error td{background-color:#f2dede}.table tbody tr.warning td{background-color:#fcf8e3}.table tbody tr.info td{background-color:#d9edf7}.table-hover tbody tr.success:hover td{background-color:#d0e9c6}.table-hover tbody tr.error:hover td{background-color:#ebcccc}.table-hover tbody tr.warning:hover td{background-color:#faf2cc}.table-hover tbody tr.info:hover td{background-color:#c4e3f3}[class^="icon-"],[class*=" icon-"]{display:inline-block;width:14px;height:14px;margin-top:1px;*margin-right:.3em;line-height:14px;vertical-align:text-top;background-image:url("../img/glyphicons-halflings.png");background-position:14px 14px;background-repeat:no-repeat}.icon-white,.nav-pills>.active>a>[class^="icon-"],.nav-pills>.active>a>[class*=" icon-"],.nav-list>.active>a>[class^="icon-"],.nav-list>.active>a>[class*=" icon-"],.navbar-inverse .nav>.active>a>[class^="icon-"],.navbar-inverse .nav>.active>a>[class*=" icon-"],.dropdown-menu>li>a:hover>[class^="icon-"],.dropdown-menu>li>a:hover>[class*=" icon-"],.dropdown-menu>.active>a>[class^="icon-"],.dropdown-menu>.active>a>[class*=" icon-"],.dropdown-submenu:hover>a>[class^="icon-"],.dropdown-submenu:hover>a>[class*=" icon-"]{background-image:url("../img/glyphicons-halflings-white.png")}.icon-glass{background-position:0 0}.icon-music{background-position:-24px 0}.icon-search{background-position:-48px 0}.icon-envelope{background-position:-72px 0}.icon-heart{background-position:-96px 0}.icon-star{background-position:-120px 0}.icon-star-empty{background-position:-144px 0}.icon-user{background-position:-168px 0}.icon-film{background-position:-192px 0}.icon-th-large{background-position:-216px 0}.icon-th{background-position:-240px 0}.icon-th-list{background-position:-264px 0}.icon-ok{background-position:-288px 0}.icon-remove{background-position:-312px 0}.icon-zoom-in{background-position:-336px 0}.icon-zoom-out{background-position:-360px 0}.icon-off{background-position:-384px 0}.icon-signal{background-position:-408px 0}.icon-cog{background-position:-432px 0}.icon-trash{background-position:-456px 0}.icon-home{background-position:0 -24px}.icon-file{background-position:-24px -24px}.icon-time{background-position:-48px -24px}.icon-road{background-position:-72px -24px}.icon-download-alt{background-position:-96px -24px}.icon-download{background-position:-120px -24px}.icon-upload{background-position:-144px -24px}.icon-inbox{background-position:-168px -24px}.icon-play-circle{background-position:-192px -24px}.icon-repeat{background-position:-216px -24px}.icon-refresh{background-position:-240px -24px}.icon-list-alt{background-position:-264px -24px}.icon-lock{background-position:-287px -24px}.icon-flag{background-position:-312px -24px}.icon-headphones{background-position:-336px -24px}.icon-volume-off{background-position:-360px -24px}.icon-volume-down{background-position:-384px -24px}.icon-volume-up{background-position:-408px -24px}.icon-qrcode{background-position:-432px -24px}.icon-barcode{background-position:-456px -24px}.icon-tag{background-position:0 -48px}.icon-tags{background-position:-25px -48px}.icon-book{background-position:-48px -48px}.icon-bookmark{background-position:-72px -48px}.icon-print{background-position:-96px -48px}.icon-camera{background-position:-120px -48px}.icon-font{background-position:-144px -48px}.icon-bold{background-position:-167px -48px}.icon-italic{background-position:-192px -48px}.icon-text-height{background-position:-216px -48px}.icon-text-width{background-position:-240px -48px}.icon-align-left{background-position:-264px -48px}.icon-align-center{background-position:-288px -48px}.icon-align-right{background-position:-312px -48px}.icon-align-justify{background-position:-336px -48px}.icon-list{background-position:-360px -48px}.icon-indent-left{background-position:-384px -48px}.icon-indent-right{background-position:-408px -48px}.icon-facetime-video{background-position:-432px -48px}.icon-picture{background-position:-456px -48px}.icon-pencil{background-position:0 -72px}.icon-map-marker{background-position:-24px -72px}.icon-adjust{background-position:-48px -72px}.icon-tint{background-position:-72px -72px}.icon-edit{background-position:-96px -72px}.icon-share{background-position:-120px -72px}.icon-check{background-position:-144px -72px}.icon-move{background-position:-168px -72px}.icon-step-backward{background-position:-192px -72px}.icon-fast-backward{background-position:-216px -72px}.icon-backward{background-position:-240px -72px}.icon-play{background-position:-264px -72px}.icon-pause{background-position:-288px -72px}.icon-stop{background-position:-312px -72px}.icon-forward{background-position:-336px -72px}.icon-fast-forward{background-position:-360px -72px}.icon-step-forward{background-position:-384px -72px}.icon-eject{background-position:-408px -72px}.icon-chevron-left{background-position:-432px -72px}.icon-chevron-right{background-position:-456px -72px}.icon-plus-sign{background-position:0 -96px}.icon-minus-sign{background-position:-24px -96px}.icon-remove-sign{background-position:-48px -96px}.icon-ok-sign{background-position:-72px -96px}.icon-question-sign{background-position:-96px -96px}.icon-info-sign{background-position:-120px -96px}.icon-screenshot{background-position:-144px -96px}.icon-remove-circle{background-position:-168px -96px}.icon-ok-circle{background-position:-192px -96px}.icon-ban-circle{background-position:-216px -96px}.icon-arrow-left{background-position:-240px -96px}.icon-arrow-right{background-position:-264px -96px}.icon-arrow-up{background-position:-289px -96px}.icon-arrow-down{background-position:-312px -96px}.icon-share-alt{background-position:-336px -96px}.icon-resize-full{background-position:-360px -96px}.icon-resize-small{background-position:-384px -96px}.icon-plus{background-position:-408px -96px}.icon-minus{background-position:-433px -96px}.icon-asterisk{background-position:-456px -96px}.icon-exclamation-sign{background-position:0 -120px}.icon-gift{background-position:-24px -120px}.icon-leaf{background-position:-48px -120px}.icon-fire{background-position:-72px -120px}.icon-eye-open{background-position:-96px -120px}.icon-eye-close{background-position:-120px -120px}.icon-warning-sign{background-position:-144px -120px}.icon-plane{background-position:-168px -120px}.icon-calendar{background-position:-192px -120px}.icon-random{width:16px;background-position:-216px -120px}.icon-comment{background-position:-240px -120px}.icon-magnet{background-position:-264px -120px}.icon-chevron-up{background-position:-288px -120px}.icon-chevron-down{background-position:-313px -119px}.icon-retweet{background-position:-336px -120px}.icon-shopping-cart{background-position:-360px -120px}.icon-folder-close{background-position:-384px -120px}.icon-folder-open{width:16px;background-position:-408px -120px}.icon-resize-vertical{background-position:-432px -119px}.icon-resize-horizontal{background-position:-456px -118px}.icon-hdd{background-position:0 -144px}.icon-bullhorn{background-position:-24px -144px}.icon-bell{background-position:-48px -144px}.icon-certificate{background-position:-72px -144px}.icon-thumbs-up{background-position:-96px -144px}.icon-thumbs-down{background-position:-120px -144px}.icon-hand-right{background-position:-144px -144px}.icon-hand-left{background-position:-168px -144px}.icon-hand-up{background-position:-192px -144px}.icon-hand-down{background-position:-216px -144px}.icon-circle-arrow-right{background-position:-240px -144px}.icon-circle-arrow-left{background-position:-264px -144px}.icon-circle-arrow-up{background-position:-288px -144px}.icon-circle-arrow-down{background-position:-312px -144px}.icon-globe{background-position:-336px -144px}.icon-wrench{background-position:-360px -144px}.icon-tasks{background-position:-384px -144px}.icon-filter{background-position:-408px -144px}.icon-briefcase{background-position:-432px -144px}.icon-fullscreen{background-position:-456px -144px}.dropup,.dropdown{position:relative}.dropdown-toggle{*margin-bottom:-3px}.dropdown-toggle:active,.open .dropdown-toggle{outline:0}.caret{display:inline-block;width:0;height:0;vertical-align:top;border-top:4px solid #000;border-right:4px solid transparent;border-left:4px solid transparent;content:""}.dropdown .caret{margin-top:8px;margin-left:2px}.dropdown-menu{position:absolute;top:100%;left:0;z-index:1000;display:none;float:left;min-width:160px;padding:5px 0;margin:2px 0 0;list-style:none;background-color:#fff;border:1px solid #ccc;border:1px solid rgba(0,0,0,0.2);*border-right-width:2px;*border-bottom-width:2px;-webkit-border-radius:6px;-moz-border-radius:6px;border-radius:6px;-webkit-box-shadow:0 5px 10px rgba(0,0,0,0.2);-moz-box-shadow:0 5px 10px rgba(0,0,0,0.2);box-shadow:0 5px 10px rgba(0,0,0,0.2);-webkit-background-clip:padding-box;-moz-background-clip:padding;background-clip:padding-box}.dropdown-menu.pull-right{right:0;left:auto}.dropdown-menu .divider{*width:100%;height:1px;margin:9px 1px;*margin:-5px 0 5px;overflow:hidden;background-color:#e5e5e5;border-bottom:1px solid #fff}.dropdown-menu li>a{display:block;padding:3px 20px;clear:both;font-weight:normal;line-height:20px;color:#333;white-space:nowrap}.dropdown-menu li>a:hover,.dropdown-menu li>a:focus,.dropdown-submenu:hover>a{color:#fff;text-decoration:none;background-color:#0081c2;background-image:-moz-linear-gradient(top,#08c,#0077b3);background-image:-webkit-gradient(linear,0 0,0 100%,from(#08c),to(#0077b3));background-image:-webkit-linear-gradient(top,#08c,#0077b3);background-image:-o-linear-gradient(top,#08c,#0077b3);background-image:linear-gradient(to bottom,#08c,#0077b3);background-repeat:repeat-x;filter:progid:DXImageTransform.Microsoft.gradient(startColorstr='#ff0088cc',endColorstr='#ff0077b3',GradientType=0)}.dropdown-menu .active>a,.dropdown-menu .active>a:hover{color:#fff;text-decoration:none;background-color:#0081c2;background-image:-moz-linear-gradient(top,#08c,#0077b3);background-image:-webkit-gradient(linear,0 0,0 100%,from(#08c),to(#0077b3));background-image:-webkit-linear-gradient(top,#08c,#0077b3);background-image:-o-linear-gradient(top,#08c,#0077b3);background-image:linear-gradient(to bottom,#08c,#0077b3);background-repeat:repeat-x;outline:0;filter:progid:DXImageTransform.Microsoft.gradient(startColorstr='#ff0088cc',endColorstr='#ff0077b3',GradientType=0)}.dropdown-menu .disabled>a,.dropdown-menu .disabled>a:hover{color:#999}.dropdown-menu .disabled>a:hover{text-decoration:none;cursor:default;background-color:transparent;background-image:none;filter:progid:DXImageTransform.Microsoft.gradient(enabled=false)}.open{*z-index:1000}.open>.dropdown-menu{display:block}.pull-right>.dropdown-menu{right:0;left:auto}.dropup .caret,.navbar-fixed-bottom .dropdown .caret{border-top:0;border-bottom:4px solid #000;content:""}.dropup .dropdown-menu,.navbar-fixed-bottom .dropdown .dropdown-menu{top:auto;bottom:100%;margin-bottom:1px}.dropdown-submenu{position:relative}.dropdown-submenu>.dropdown-menu{top:0;left:100%;margin-top:-6px;margin-left:-1px;-webkit-border-radius:0 6px 6px 6px;-moz-border-radius:0 6px 6px 6px;border-radius:0 6px 6px 6px}.dropdown-submenu:hover>.dropdown-menu{display:block}.dropup .dropdown-submenu>.dropdown-menu{top:auto;bottom:0;margin-top:0;margin-bottom:-2px;-webkit-border-radius:5px 5px 5px 0;-moz-border-radius:5px 5px 5px 0;border-radius:5px 5px 5px 0}.dropdown-submenu>a:after{display:block;float:right;width:0;height:0;margin-top:5px;margin-right:-10px;border-color:transparent;border-left-color:#ccc;border-style:solid;border-width:5px 0 5px 5px;content:" "}.dropdown-submenu:hover>a:after{border-left-color:#fff}.dropdown-submenu.pull-left{float:none}.dropdown-submenu.pull-left>.dropdown-menu{left:-100%;margin-left:10px;-webkit-border-radius:6px 0 6px 6px;-moz-border-radius:6px 0 6px 6px;border-radius:6px 0 6px 6px}.dropdown .dropdown-menu .nav-header{padding-right:20px;padding-left:20px}.typeahead{z-index:1051;margin-top:2px;-webkit-border-radius:4px;-moz-border-radius:4px;border-radius:4px}.well{min-height:20px;padding:19px;margin-bottom:20px;background-color:#f5f5f5;border:1px solid #e3e3e3;-webkit-border-radius:4px;-moz-border-radius:4px;border-radius:4px;-webkit-box-shadow:inset 0 1px 1px rgba(0,0,0,0.05);-moz-box-shadow:inset 0 1px 1px rgba(0,0,0,0.05);box-shadow:inset 0 1px 1px rgba(0,0,0,0.05)}.well blockquote{border-color:#ddd;border-color:rgba(0,0,0,0.15)}.well-large{padding:24px;-webkit-border-radius:6px;-moz-border-radius:6px;border-radius:6px}.well-small{padding:9px;-webkit-border-radius:3px;-moz-border-radius:3px;border-radius:3px}.fade{opacity:0;-webkit-transition:opacity .15s linear;-moz-transition:opacity .15s linear;-o-transition:opacity .15s linear;transition:opacity .15s linear}.fade.in{opacity:1}.collapse{position:relative;height:0;overflow:hidden;-webkit-transition:height .35s ease;-moz-transition:height .35s ease;-o-transition:height .35s ease;transition:height .35s ease}.collapse.in{height:auto}.close{float:right;font-size:20px;font-weight:bold;line-height:20px;color:#000;text-shadow:0 1px 0 #fff;opacity:.2;filter:alpha(opacity=20)}.close:hover{color:#000;text-decoration:none;cursor:pointer;opacity:.4;filter:alpha(opacity=40)}button.close{padding:0;cursor:pointer;background:transparent;border:0;-webkit-appearance:none}.btn{display:inline-block;*display:inline;padding:4px 12px;margin-bottom:0;*margin-left:.3em;font-size:14px;line-height:20px;color:#333;text-align:center;text-shadow:0 1px 1px rgba(255,255,255,0.75);vertical-align:middle;cursor:pointer;background-color:#f5f5f5;*background-color:#e6e6e6;background-image:-moz-linear-gradient(top,#fff,#e6e6e6);background-image:-webkit-gradient(linear,0 0,0 100%,from(#fff),to(#e6e6e6));background-image:-webkit-linear-gradient(top,#fff,#e6e6e6);background-image:-o-linear-gradient(top,#fff,#e6e6e6);background-image:linear-gradient(to bottom,#fff,#e6e6e6);background-repeat:repeat-x;border:1px solid #bbb;*border:0;border-color:#e6e6e6 #e6e6e6 #bfbfbf;border-color:rgba(0,0,0,0.1) rgba(0,0,0,0.1) rgba(0,0,0,0.25);border-bottom-color:#a2a2a2;-webkit-border-radius:4px;-moz-border-radius:4px;border-radius:4px;filter:progid:DXImageTransform.Microsoft.gradient(startColorstr='#ffffffff',endColorstr='#ffe6e6e6',GradientType=0);filter:progid:DXImageTransform.Microsoft.gradient(enabled=false);*zoom:1;-webkit-box-shadow:inset 0 1px 0 rgba(255,255,255,0.2),0 1px 2px rgba(0,0,0,0.05);-moz-box-shadow:inset 0 1px 0 rgba(255,255,255,0.2),0 1px 2px rgba(0,0,0,0.05);box-shadow:inset 0 1px 0 rgba(255,255,255,0.2),0 1px 2px rgba(0,0,0,0.05)}.btn:hover,.btn:active,.btn.active,.btn.disabled,.btn[disabled]{color:#333;background-color:#e6e6e6;*background-color:#d9d9d9}.btn:active,.btn.active{background-color:#ccc \9}.btn:first-child{*margin-left:0}.btn:hover{color:#333;text-decoration:none;background-position:0 -15px;-webkit-transition:background-position .1s linear;-moz-transition:background-position .1s linear;-o-transition:background-position .1s linear;transition:background-position .1s linear}.btn:focus{outline:thin dotted #333;outline:5px auto -webkit-focus-ring-color;outline-offset:-2px}.btn.active,.btn:active{background-image:none;outline:0;-webkit-box-shadow:inset 0 2px 4px rgba(0,0,0,0.15),0 1px 2px rgba(0,0,0,0.05);-moz-box-shadow:inset 0 2px 4px rgba(0,0,0,0.15),0 1px 2px rgba(0,0,0,0.05);box-shadow:inset 0 2px 4px rgba(0,0,0,0.15),0 1px 2px rgba(0,0,0,0.05)}.btn.disabled,.btn[disabled]{cursor:default;background-image:none;opacity:.65;filter:alpha(opacity=65);-webkit-box-shadow:none;-moz-box-shadow:none;box-shadow:none}.btn-large{padding:11px 19px;font-size:17.5px;-webkit-border-radius:6px;-moz-border-radius:6px;border-radius:6px}.btn-large [class^="icon-"],.btn-large [class*=" icon-"]{margin-top:4px}.btn-small{padding:2px 10px;font-size:11.9px;-webkit-border-radius:3px;-moz-border-radius:3px;border-radius:3px}.btn-small [class^="icon-"],.btn-small [class*=" icon-"]{margin-top:0}.btn-mini [class^="icon-"],.btn-mini [class*=" icon-"]{margin-top:-1px}.btn-mini{padding:0 6px;font-size:10.5px;-webkit-border-radius:3px;-moz-border-radius:3px;border-radius:3px}.btn-block{display:block;width:100%;padding-right:0;padding-left:0;-webkit-box-sizing:border-box;-moz-box-sizing:border-box;box-sizing:border-box}.btn-block+.btn-block{margin-top:5px}input[type="submit"].btn-block,input[type="reset"].btn-block,input[type="button"].btn-block{width:100%}.btn-primary.active,.btn-warning.active,.btn-danger.active,.btn-success.active,.btn-info.active,.btn-inverse.active{color:rgba(255,255,255,0.75)}.btn{border-color:#c5c5c5;border-color:rgba(0,0,0,0.15) rgba(0,0,0,0.15) rgba(0,0,0,0.25)}.btn-primary{color:#fff;text-shadow:0 -1px 0 rgba(0,0,0,0.25);background-color:#006dcc;*background-color:#04c;background-image:-moz-linear-gradient(top,#08c,#04c);background-image:-webkit-gradient(linear,0 0,0 100%,from(#08c),to(#04c));background-image:-webkit-linear-gradient(top,#08c,#04c);background-image:-o-linear-gradient(top,#08c,#04c);background-image:linear-gradient(to bottom,#08c,#04c);background-repeat:repeat-x;border-color:#04c #04c #002a80;border-color:rgba(0,0,0,0.1) rgba(0,0,0,0.1) rgba(0,0,0,0.25);filter:progid:DXImageTransform.Microsoft.gradient(startColorstr='#ff0088cc',endColorstr='#ff0044cc',GradientType=0);filter:progid:DXImageTransform.Microsoft.gradient(enabled=false)}.btn-primary:hover,.btn-primary:active,.btn-primary.active,.btn-primary.disabled,.btn-primary[disabled]{color:#fff;background-color:#04c;*background-color:#003bb3}.btn-primary:active,.btn-primary.active{background-color:#039 \9}.btn-warning{color:#fff;text-shadow:0 -1px 0 rgba(0,0,0,0.25);background-color:#faa732;*background-color:#f89406;background-image:-moz-linear-gradient(top,#fbb450,#f89406);background-image:-webkit-gradient(linear,0 0,0 100%,from(#fbb450),to(#f89406));background-image:-webkit-linear-gradient(top,#fbb450,#f89406);background-image:-o-linear-gradient(top,#fbb450,#f89406);background-image:linear-gradient(to bottom,#fbb450,#f89406);background-repeat:repeat-x;border-color:#f89406 #f89406 #ad6704;border-color:rgba(0,0,0,0.1) rgba(0,0,0,0.1) rgba(0,0,0,0.25);filter:progid:DXImageTransform.Microsoft.gradient(startColorstr='#fffbb450',endColorstr='#fff89406',GradientType=0);filter:progid:DXImageTransform.Microsoft.gradient(enabled=false)}.btn-warning:hover,.btn-warning:active,.btn-warning.active,.btn-warning.disabled,.btn-warning[disabled]{color:#fff;background-color:#f89406;*background-color:#df8505}.btn-warning:active,.btn-warning.active{background-color:#c67605 \9}.btn-danger{color:#fff;text-shadow:0 -1px 0 rgba(0,0,0,0.25);background-color:#da4f49;*background-color:#bd362f;background-image:-moz-linear-gradient(top,#ee5f5b,#bd362f);background-image:-webkit-gradient(linear,0 0,0 100%,from(#ee5f5b),to(#bd362f));background-image:-webkit-linear-gradient(top,#ee5f5b,#bd362f);background-image:-o-linear-gradient(top,#ee5f5b,#bd362f);background-image:linear-gradient(to bottom,#ee5f5b,#bd362f);background-repeat:repeat-x;border-color:#bd362f #bd362f #802420;border-color:rgba(0,0,0,0.1) rgba(0,0,0,0.1) rgba(0,0,0,0.25);filter:progid:DXImageTransform.Microsoft.gradient(startColorstr='#ffee5f5b',endColorstr='#ffbd362f',GradientType=0);filter:progid:DXImageTransform.Microsoft.gradient(enabled=false)}.btn-danger:hover,.btn-danger:active,.btn-danger.active,.btn-danger.disabled,.btn-danger[disabled]{color:#fff;background-color:#bd362f;*background-color:#a9302a}.btn-danger:active,.btn-danger.active{background-color:#942a25 \9}.btn-success{color:#fff;text-shadow:0 -1px 0 rgba(0,0,0,0.25);background-color:#5bb75b;*background-color:#51a351;background-image:-moz-linear-gradient(top,#62c462,#51a351);background-image:-webkit-gradient(linear,0 0,0 100%,from(#62c462),to(#51a351));background-image:-webkit-linear-gradient(top,#62c462,#51a351);background-image:-o-linear-gradient(top,#62c462,#51a351);background-image:linear-gradient(to bottom,#62c462,#51a351);background-repeat:repeat-x;border-color:#51a351 #51a351 #387038;border-color:rgba(0,0,0,0.1) rgba(0,0,0,0.1) rgba(0,0,0,0.25);filter:progid:DXImageTransform.Microsoft.gradient(startColorstr='#ff62c462',endColorstr='#ff51a351',GradientType=0);filter:progid:DXImageTransform.Microsoft.gradient(enabled=false)}.btn-success:hover,.btn-success:active,.btn-success.active,.btn-success.disabled,.btn-success[disabled]{color:#fff;background-color:#51a351;*background-color:#499249}.btn-success:active,.btn-success.active{background-color:#408140 \9}.btn-info{color:#fff;text-shadow:0 -1px 0 rgba(0,0,0,0.25);background-color:#49afcd;*background-color:#2f96b4;background-image:-moz-linear-gradient(top,#5bc0de,#2f96b4);background-image:-webkit-gradient(linear,0 0,0 100%,from(#5bc0de),to(#2f96b4));background-image:-webkit-linear-gradient(top,#5bc0de,#2f96b4);background-image:-o-linear-gradient(top,#5bc0de,#2f96b4);background-image:linear-gradient(to bottom,#5bc0de,#2f96b4);background-repeat:repeat-x;border-color:#2f96b4 #2f96b4 #1f6377;border-color:rgba(0,0,0,0.1) rgba(0,0,0,0.1) rgba(0,0,0,0.25);filter:progid:DXImageTransform.Microsoft.gradient(startColorstr='#ff5bc0de',endColorstr='#ff2f96b4',GradientType=0);filter:progid:DXImageTransform.Microsoft.gradient(enabled=false)}.btn-info:hover,.btn-info:active,.btn-info.active,.btn-info.disabled,.btn-info[disabled]{color:#fff;background-color:#2f96b4;*background-color:#2a85a0}.btn-info:active,.btn-info.active{background-color:#24748c \9}.btn-inverse{color:#fff;text-shadow:0 -1px 0 rgba(0,0,0,0.25);background-color:#363636;*background-color:#222;background-image:-moz-linear-gradient(top,#444,#222);background-image:-webkit-gradient(linear,0 0,0 100%,from(#444),to(#222));background-image:-webkit-linear-gradient(top,#444,#222);background-image:-o-linear-gradient(top,#444,#222);background-image:linear-gradient(to bottom,#444,#222);background-repeat:repeat-x;border-color:#222 #222 #000;border-color:rgba(0,0,0,0.1) rgba(0,0,0,0.1) rgba(0,0,0,0.25);filter:progid:DXImageTransform.Microsoft.gradient(startColorstr='#ff444444',endColorstr='#ff222222',GradientType=0);filter:progid:DXImageTransform.Microsoft.gradient(enabled=false)}.btn-inverse:hover,.btn-inverse:active,.btn-inverse.active,.btn-inverse.disabled,.btn-inverse[disabled]{color:#fff;background-color:#222;*background-color:#151515}.btn-inverse:active,.btn-inverse.active{background-color:#080808 \9}button.btn,input[type="submit"].btn{*padding-top:3px;*padding-bottom:3px}button.btn::-moz-focus-inner,input[type="submit"].btn::-moz-focus-inner{padding:0;border:0}button.btn.btn-large,input[type="submit"].btn.btn-large{*padding-top:7px;*padding-bottom:7px}button.btn.btn-small,input[type="submit"].btn.btn-small{*padding-top:3px;*padding-bottom:3px}button.btn.btn-mini,input[type="submit"].btn.btn-mini{*padding-top:1px;*padding-bottom:1px}.btn-link,.btn-link:active,.btn-link[disabled]{background-color:transparent;background-image:none;-webkit-box-shadow:none;-moz-box-shadow:none;box-shadow:none}.btn-link{color:#08c;cursor:pointer;border-color:transparent;-webkit-border-radius:0;-moz-border-radius:0;border-radius:0}.btn-link:hover{color:#005580;text-decoration:underline;background-color:transparent}.btn-link[disabled]:hover{color:#333;text-decoration:none}.btn-group{position:relative;display:inline-block;*display:inline;*margin-left:.3em;font-size:0;white-space:nowrap;vertical-align:middle;*zoom:1}.btn-group:first-child{*margin-left:0}.btn-group+.btn-group{margin-left:5px}.btn-toolbar{margin-top:10px;margin-bottom:10px;font-size:0}.btn-toolbar>.btn+.btn,.btn-toolbar>.btn-group+.btn,.btn-toolbar>.btn+.btn-group{margin-left:5px}.btn-group>.btn{position:relative;-webkit-border-radius:0;-moz-border-radius:0;border-radius:0}.btn-group>.btn+.btn{margin-left:-1px}.btn-group>.btn,.btn-group>.dropdown-menu,.btn-group>.popover{font-size:14px}.btn-group>.btn-mini{font-size:10.5px}.btn-group>.btn-small{font-size:11.9px}.btn-group>.btn-large{font-size:17.5px}.btn-group>.btn:first-child{margin-left:0;-webkit-border-bottom-left-radius:4px;border-bottom-left-radius:4px;-webkit-border-top-left-radius:4px;border-top-left-radius:4px;-moz-border-radius-bottomleft:4px;-moz-border-radius-topleft:4px}.btn-group>.btn:last-child,.btn-group>.dropdown-toggle{-webkit-border-top-right-radius:4px;border-top-right-radius:4px;-webkit-border-bottom-right-radius:4px;border-bottom-right-radius:4px;-moz-border-radius-topright:4px;-moz-border-radius-bottomright:4px}.btn-group>.btn.large:first-child{margin-left:0;-webkit-border-bottom-left-radius:6px;border-bottom-left-radius:6px;-webkit-border-top-left-radius:6px;border-top-left-radius:6px;-moz-border-radius-bottomleft:6px;-moz-border-radius-topleft:6px}.btn-group>.btn.large:last-child,.btn-group>.large.dropdown-toggle{-webkit-border-top-right-radius:6px;border-top-right-radius:6px;-webkit-border-bottom-right-radius:6px;border-bottom-right-radius:6px;-moz-border-radius-topright:6px;-moz-border-radius-bottomright:6px}.btn-group>.btn:hover,.btn-group>.btn:focus,.btn-group>.btn:active,.btn-group>.btn.active{z-index:2}.btn-group .dropdown-toggle:active,.btn-group.open .dropdown-toggle{outline:0}.btn-group>.btn+.dropdown-toggle{*padding-top:5px;padding-right:8px;*padding-bottom:5px;padding-left:8px;-webkit-box-shadow:inset 1px 0 0 rgba(255,255,255,0.125),inset 0 1px 0 rgba(255,255,255,0.2),0 1px 2px rgba(0,0,0,0.05);-moz-box-shadow:inset 1px 0 0 rgba(255,255,255,0.125),inset 0 1px 0 rgba(255,255,255,0.2),0 1px 2px rgba(0,0,0,0.05);box-shadow:inset 1px 0 0 rgba(255,255,255,0.125),inset 0 1px 0 rgba(255,255,255,0.2),0 1px 2px rgba(0,0,0,0.05)}.btn-group>.btn-mini+.dropdown-toggle{*padding-top:2px;padding-right:5px;*padding-bottom:2px;padding-left:5px}.btn-group>.btn-small+.dropdown-toggle{*padding-top:5px;*padding-bottom:4px}.btn-group>.btn-large+.dropdown-toggle{*padding-top:7px;padding-right:12px;*padding-bottom:7px;padding-left:12px}.btn-group.open .dropdown-toggle{background-image:none;-webkit-box-shadow:inset 0 2px 4px rgba(0,0,0,0.15),0 1px 2px rgba(0,0,0,0.05);-moz-box-shadow:inset 0 2px 4px rgba(0,0,0,0.15),0 1px 2px rgba(0,0,0,0.05);box-shadow:inset 0 2px 4px rgba(0,0,0,0.15),0 1px 2px rgba(0,0,0,0.05)}.btn-group.open .btn.dropdown-toggle{background-color:#e6e6e6}.btn-group.open .btn-primary.dropdown-toggle{background-color:#04c}.btn-group.open .btn-warning.dropdown-toggle{background-color:#f89406}.btn-group.open .btn-danger.dropdown-toggle{background-color:#bd362f}.btn-group.open .btn-success.dropdown-toggle{background-color:#51a351}.btn-group.open .btn-info.dropdown-toggle{background-color:#2f96b4}.btn-group.open .btn-inverse.dropdown-toggle{background-color:#222}.btn .caret{margin-top:8px;margin-left:0}.btn-mini .caret,.btn-small .caret,.btn-large .caret{margin-top:6px}.btn-large .caret{border-top-width:5px;border-right-width:5px;border-left-width:5px}.dropup .btn-large .caret{border-bottom-width:5px}.btn-primary .caret,.btn-warning .caret,.btn-danger .caret,.btn-info .caret,.btn-success .caret,.btn-inverse .caret{border-top-color:#fff;border-bottom-color:#fff}.btn-group-vertical{display:inline-block;*display:inline;*zoom:1}.btn-group-vertical>.btn{display:block;float:none;max-width:100%;-webkit-border-radius:0;-moz-border-radius:0;border-radius:0}.btn-group-vertical>.btn+.btn{margin-top:-1px;margin-left:0}.btn-group-vertical>.btn:first-child{-webkit-border-radius:4px 4px 0 0;-moz-border-radius:4px 4px 0 0;border-radius:4px 4px 0 0}.btn-group-vertical>.btn:last-child{-webkit-border-radius:0 0 4px 4px;-moz-border-radius:0 0 4px 4px;border-radius:0 0 4px 4px}.btn-group-vertical>.btn-large:first-child{-webkit-border-radius:6px 6px 0 0;-moz-border-radius:6px 6px 0 0;border-radius:6px 6px 0 0}.btn-group-vertical>.btn-large:last-child{-webkit-border-radius:0 0 6px 6px;-moz-border-radius:0 0 6px 6px;border-radius:0 0 6px 6px}.alert{padding:8px 35px 8px 14px;margin-bottom:20px;text-shadow:0 1px 0 rgba(255,255,255,0.5);background-color:#fcf8e3;border:1px solid #fbeed5;-webkit-border-radius:4px;-moz-border-radius:4px;border-radius:4px}.alert,.alert h4{color:#c09853}.alert h4{margin:0}.alert .close{position:relative;top:-2px;right:-21px;line-height:20px}.alert-success{color:#468847;background-color:#dff0d8;border-color:#d6e9c6}.alert-success h4{color:#468847}.alert-danger,.alert-error{color:#b94a48;background-color:#f2dede;border-color:#eed3d7}.alert-danger h4,.alert-error h4{color:#b94a48}.alert-info{color:#3a87ad;background-color:#d9edf7;border-color:#bce8f1}.alert-info h4{color:#3a87ad}.alert-block{padding-top:14px;padding-bottom:14px}.alert-block>p,.alert-block>ul{margin-bottom:0}.alert-block p+p{margin-top:5px}.nav{margin-bottom:20px;margin-left:0;list-style:none}.nav>li>a{display:block}.nav>li>a:hover{text-decoration:none;background-color:#eee}.nav>li>a>img{max-width:none}.nav>.pull-right{float:right}.nav-header{display:block;padding:3px 15px;font-size:11px;font-weight:bold;line-height:20px;color:#999;text-shadow:0 1px 0 rgba(255,255,255,0.5);text-transform:uppercase}.nav li+.nav-header{margin-top:9px}.nav-list{padding-right:15px;padding-left:15px;margin-bottom:0}.nav-list>li>a,.nav-list .nav-header{margin-right:-15px;margin-left:-15px;text-shadow:0 1px 0 rgba(255,255,255,0.5)}.nav-list>li>a{padding:3px 15px}.nav-list>.active>a,.nav-list>.active>a:hover{color:#fff;text-shadow:0 -1px 0 rgba(0,0,0,0.2);background-color:#08c}.nav-list [class^="icon-"],.nav-list [class*=" icon-"]{margin-right:2px}.nav-list .divider{*width:100%;height:1px;margin:9px 1px;*margin:-5px 0 5px;overflow:hidden;background-color:#e5e5e5;border-bottom:1px solid #fff}.nav-tabs,.nav-pills{*zoom:1}.nav-tabs:before,.nav-pills:before,.nav-tabs:after,.nav-pills:after{display:table;line-height:0;content:""}.nav-tabs:after,.nav-pills:after{clear:both}.nav-tabs>li,.nav-pills>li{float:left}.nav-tabs>li>a,.nav-pills>li>a{padding-right:12px;padding-left:12px;margin-right:2px;line-height:14px}.nav-tabs{border-bottom:1px solid #ddd}.nav-tabs>li{margin-bottom:-1px}.nav-tabs>li>a{padding-top:8px;padding-bottom:8px;line-height:20px;border:1px solid transparent;-webkit-border-radius:4px 4px 0 0;-moz-border-radius:4px 4px 0 0;border-radius:4px 4px 0 0}.nav-tabs>li>a:hover{border-color:#eee #eee #ddd}.nav-tabs>.active>a,.nav-tabs>.active>a:hover{color:#555;cursor:default;background-color:#fff;border:1px solid #ddd;border-bottom-color:transparent}.nav-pills>li>a{padding-top:8px;padding-bottom:8px;margin-top:2px;margin-bottom:2px;-webkit-border-radius:5px;-moz-border-radius:5px;border-radius:5px}.nav-pills>.active>a,.nav-pills>.active>a:hover{color:#fff;background-color:#08c}.nav-stacked>li{float:none}.nav-stacked>li>a{margin-right:0}.nav-tabs.nav-stacked{border-bottom:0}.nav-tabs.nav-stacked>li>a{border:1px solid #ddd;-webkit-border-radius:0;-moz-border-radius:0;border-radius:0}.nav-tabs.nav-stacked>li:first-child>a{-webkit-border-top-right-radius:4px;border-top-right-radius:4px;-webkit-border-top-left-radius:4px;border-top-left-radius:4px;-moz-border-radius-topright:4px;-moz-border-radius-topleft:4px}.nav-tabs.nav-stacked>li:last-child>a{-webkit-border-bottom-right-radius:4px;border-bottom-right-radius:4px;-webkit-border-bottom-left-radius:4px;border-bottom-left-radius:4px;-moz-border-radius-bottomright:4px;-moz-border-radius-bottomleft:4px}.nav-tabs.nav-stacked>li>a:hover{z-index:2;border-color:#ddd}.nav-pills.nav-stacked>li>a{margin-bottom:3px}.nav-pills.nav-stacked>li:last-child>a{margin-bottom:1px}.nav-tabs .dropdown-menu{-webkit-border-radius:0 0 6px 6px;-moz-border-radius:0 0 6px 6px;border-radius:0 0 6px 6px}.nav-pills .dropdown-menu{-webkit-border-radius:6px;-moz-border-radius:6px;border-radius:6px}.nav .dropdown-toggle .caret{margin-top:6px;border-top-color:#08c;border-bottom-color:#08c}.nav .dropdown-toggle:hover .caret{border-top-color:#005580;border-bottom-color:#005580}.nav-tabs .dropdown-toggle .caret{margin-top:8px}.nav .active .dropdown-toggle .caret{border-top-color:#fff;border-bottom-color:#fff}.nav-tabs .active .dropdown-toggle .caret{border-top-color:#555;border-bottom-color:#555}.nav>.dropdown.active>a:hover{cursor:pointer}.nav-tabs .open .dropdown-toggle,.nav-pills .open .dropdown-toggle,.nav>li.dropdown.open.active>a:hover{color:#fff;background-color:#999;border-color:#999}.nav li.dropdown.open .caret,.nav li.dropdown.open.active .caret,.nav li.dropdown.open a:hover .caret{border-top-color:#fff;border-bottom-color:#fff;opacity:1;filter:alpha(opacity=100)}.tabs-stacked .open>a:hover{border-color:#999}.tabbable{*zoom:1}.tabbable:before,.tabbable:after{display:table;line-height:0;content:""}.tabbable:after{clear:both}.tab-content{overflow:auto}.tabs-below>.nav-tabs,.tabs-right>.nav-tabs,.tabs-left>.nav-tabs{border-bottom:0}.tab-content>.tab-pane,.pill-content>.pill-pane{display:none}.tab-content>.active,.pill-content>.active{display:block}.tabs-below>.nav-tabs{border-top:1px solid #ddd}.tabs-below>.nav-tabs>li{margin-top:-1px;margin-bottom:0}.tabs-below>.nav-tabs>li>a{-webkit-border-radius:0 0 4px 4px;-moz-border-radius:0 0 4px 4px;border-radius:0 0 4px 4px}.tabs-below>.nav-tabs>li>a:hover{border-top-color:#ddd;border-bottom-color:transparent}.tabs-below>.nav-tabs>.active>a,.tabs-below>.nav-tabs>.active>a:hover{border-color:transparent #ddd #ddd #ddd}.tabs-left>.nav-tabs>li,.tabs-right>.nav-tabs>li{float:none}.tabs-left>.nav-tabs>li>a,.tabs-right>.nav-tabs>li>a{min-width:74px;margin-right:0;margin-bottom:3px}.tabs-left>.nav-tabs{float:left;margin-right:19px;border-right:1px solid #ddd}.tabs-left>.nav-tabs>li>a{margin-right:-1px;-webkit-border-radius:4px 0 0 4px;-moz-border-radius:4px 0 0 4px;border-radius:4px 0 0 4px}.tabs-left>.nav-tabs>li>a:hover{border-color:#eee #ddd #eee #eee}.tabs-left>.nav-tabs .active>a,.tabs-left>.nav-tabs .active>a:hover{border-color:#ddd transparent #ddd #ddd;*border-right-color:#fff}.tabs-right>.nav-tabs{float:right;margin-left:19px;border-left:1px solid #ddd}.tabs-right>.nav-tabs>li>a{margin-left:-1px;-webkit-border-radius:0 4px 4px 0;-moz-border-radius:0 4px 4px 0;border-radius:0 4px 4px 0}.tabs-right>.nav-tabs>li>a:hover{border-color:#eee #eee #eee #ddd}.tabs-right>.nav-tabs .active>a,.tabs-right>.nav-tabs .active>a:hover{border-color:#ddd #ddd #ddd transparent;*border-left-color:#fff}.nav>.disabled>a{color:#999}.nav>.disabled>a:hover{text-decoration:none;cursor:default;background-color:transparent}.navbar{*position:relative;*z-index:2;margin-bottom:20px;overflow:visible}.navbar-inner{min-height:40px;padding-right:20px;padding-left:20px;background-color:#fafafa;background-image:-moz-linear-gradient(top,#fff,#f2f2f2);background-image:-webkit-gradient(linear,0 0,0 100%,from(#fff),to(#f2f2f2));background-image:-webkit-linear-gradient(top,#fff,#f2f2f2);background-image:-o-linear-gradient(top,#fff,#f2f2f2);background-image:linear-gradient(to bottom,#fff,#f2f2f2);background-repeat:repeat-x;border:1px solid #d4d4d4;-webkit-border-radius:4px;-moz-border-radius:4px;border-radius:4px;filter:progid:DXImageTransform.Microsoft.gradient(startColorstr='#ffffffff',endColorstr='#fff2f2f2',GradientType=0);*zoom:1;-webkit-box-shadow:0 1px 4px rgba(0,0,0,0.065);-moz-box-shadow:0 1px 4px rgba(0,0,0,0.065);box-shadow:0 1px 4px rgba(0,0,0,0.065)}.navbar-inner:before,.navbar-inner:after{display:table;line-height:0;content:""}.navbar-inner:after{clear:both}.navbar .container{width:auto}.nav-collapse.collapse{height:auto;overflow:visible}.navbar .brand{display:block;float:left;padding:10px 20px 10px;margin-left:-20px;font-size:20px;font-weight:200;color:#777;text-shadow:0 1px 0 #fff}.navbar .brand:hover{text-decoration:none}.navbar-text{margin-bottom:0;line-height:40px;color:#777}.navbar-link{color:#777}.navbar-link:hover{color:#333}.navbar .divider-vertical{height:40px;margin:0 9px;border-right:1px solid #fff;border-left:1px solid #f2f2f2}.navbar .btn,.navbar .btn-group{margin-top:5px}.navbar .btn-group .btn,.navbar .input-prepend .btn,.navbar .input-append .btn{margin-top:0}.navbar-form{margin-bottom:0;*zoom:1}.navbar-form:before,.navbar-form:after{display:table;line-height:0;content:""}.navbar-form:after{clear:both}.navbar-form input,.navbar-form select,.navbar-form .radio,.navbar-form .checkbox{margin-top:5px}.navbar-form input,.navbar-form select,.navbar-form .btn{display:inline-block;margin-bottom:0}.navbar-form input[type="image"],.navbar-form input[type="checkbox"],.navbar-form input[type="radio"]{margin-top:3px}.navbar-form .input-append,.navbar-form .input-prepend{margin-top:5px;white-space:nowrap}.navbar-form .input-append input,.navbar-form .input-prepend input{margin-top:0}.navbar-search{position:relative;float:left;margin-top:5px;margin-bottom:0}.navbar-search .search-query{padding:4px 14px;margin-bottom:0;font-family:"Helvetica Neue",Helvetica,Arial,sans-serif;font-size:13px;font-weight:normal;line-height:1;-webkit-border-radius:15px;-moz-border-radius:15px;border-radius:15px}.navbar-static-top{position:static;margin-bottom:0}.navbar-static-top .navbar-inner{-webkit-border-radius:0;-moz-border-radius:0;border-radius:0}.navbar-fixed-top,.navbar-fixed-bottom{position:fixed;right:0;left:0;z-index:1030;margin-bottom:0}.navbar-fixed-top .navbar-inner,.navbar-static-top .navbar-inner{border-width:0 0 1px}.navbar-fixed-bottom .navbar-inner{border-width:1px 0 0}.navbar-fixed-top .navbar-inner,.navbar-fixed-bottom .navbar-inner{padding-right:0;padding-left:0;-webkit-border-radius:0;-moz-border-radius:0;border-radius:0}.navbar-static-top .container,.navbar-fixed-top .container,.navbar-fixed-bottom .container{width:940px}.navbar-fixed-top{top:0}.navbar-fixed-top .navbar-inner,.navbar-static-top .navbar-inner{-webkit-box-shadow:0 1px 10px rgba(0,0,0,0.1);-moz-box-shadow:0 1px 10px rgba(0,0,0,0.1);box-shadow:0 1px 10px rgba(0,0,0,0.1)}.navbar-fixed-bottom{bottom:0}.navbar-fixed-bottom .navbar-inner{-webkit-box-shadow:0 -1px 10px rgba(0,0,0,0.1);-moz-box-shadow:0 -1px 10px rgba(0,0,0,0.1);box-shadow:0 -1px 10px rgba(0,0,0,0.1)}.navbar .nav{position:relative;left:0;display:block;float:left;margin:0 10px 0 0}.navbar .nav.pull-right{float:right;margin-right:0}.navbar .nav>li{float:left}.navbar .nav>li>a{float:none;padding:10px 15px 10px;color:#777;text-decoration:none;text-shadow:0 1px 0 #fff}.navbar .nav .dropdown-toggle .caret{margin-top:8px}.navbar .nav>li>a:focus,.navbar .nav>li>a:hover{color:#333;text-decoration:none;background-color:transparent}.navbar .nav>.active>a,.navbar .nav>.active>a:hover,.navbar .nav>.active>a:focus{color:#555;text-decoration:none;background-color:#e5e5e5;-webkit-box-shadow:inset 0 3px 8px rgba(0,0,0,0.125);-moz-box-shadow:inset 0 3px 8px rgba(0,0,0,0.125);box-shadow:inset 0 3px 8px rgba(0,0,0,0.125)}.navbar .btn-navbar{display:none;float:right;padding:7px 10px;margin-right:5px;margin-left:5px;color:#fff;text-shadow:0 -1px 0 rgba(0,0,0,0.25);background-color:#ededed;*background-color:#e5e5e5;background-image:-moz-linear-gradient(top,#f2f2f2,#e5e5e5);background-image:-webkit-gradient(linear,0 0,0 100%,from(#f2f2f2),to(#e5e5e5));background-image:-webkit-linear-gradient(top,#f2f2f2,#e5e5e5);background-image:-o-linear-gradient(top,#f2f2f2,#e5e5e5);background-image:linear-gradient(to bottom,#f2f2f2,#e5e5e5);background-repeat:repeat-x;border-color:#e5e5e5 #e5e5e5 #bfbfbf;border-color:rgba(0,0,0,0.1) rgba(0,0,0,0.1) rgba(0,0,0,0.25);filter:progid:DXImageTransform.Microsoft.gradient(startColorstr='#fff2f2f2',endColorstr='#ffe5e5e5',GradientType=0);filter:progid:DXImageTransform.Microsoft.gradient(enabled=false);-webkit-box-shadow:inset 0 1px 0 rgba(255,255,255,0.1),0 1px 0 rgba(255,255,255,0.075);-moz-box-shadow:inset 0 1px 0 rgba(255,255,255,0.1),0 1px 0 rgba(255,255,255,0.075);box-shadow:inset 0 1px 0 rgba(255,255,255,0.1),0 1px 0 rgba(255,255,255,0.075)}.navbar .btn-navbar:hover,.navbar .btn-navbar:active,.navbar .btn-navbar.active,.navbar .btn-navbar.disabled,.navbar .btn-navbar[disabled]{color:#fff;background-color:#e5e5e5;*background-color:#d9d9d9}.navbar .btn-navbar:active,.navbar .btn-navbar.active{background-color:#ccc \9}.navbar .btn-navbar .icon-bar{display:block;width:18px;height:2px;background-color:#f5f5f5;-webkit-border-radius:1px;-moz-border-radius:1px;border-radius:1px;-webkit-box-shadow:0 1px 0 rgba(0,0,0,0.25);-moz-box-shadow:0 1px 0 rgba(0,0,0,0.25);box-shadow:0 1px 0 rgba(0,0,0,0.25)}.btn-navbar .icon-bar+.icon-bar{margin-top:3px}.navbar .nav>li>.dropdown-menu:before{position:absolute;top:-7px;left:9px;display:inline-block;border-right:7px solid transparent;border-bottom:7px solid #ccc;border-left:7px solid transparent;border-bottom-color:rgba(0,0,0,0.2);content:''}.navbar .nav>li>.dropdown-menu:after{position:absolute;top:-6px;left:10px;display:inline-block;border-right:6px solid transparent;border-bottom:6px solid #fff;border-left:6px solid transparent;content:''}.navbar-fixed-bottom .nav>li>.dropdown-menu:before{top:auto;bottom:-7px;border-top:7px solid #ccc;border-bottom:0;border-top-color:rgba(0,0,0,0.2)}.navbar-fixed-bottom .nav>li>.dropdown-menu:after{top:auto;bottom:-6px;border-top:6px solid #fff;border-bottom:0}.navbar .nav li.dropdown>a:hover .caret{border-top-color:#555;border-bottom-color:#555}.navbar .nav li.dropdown.open>.dropdown-toggle,.navbar .nav li.dropdown.active>.dropdown-toggle,.navbar .nav li.dropdown.open.active>.dropdown-toggle{color:#555;background-color:#e5e5e5}.navbar .nav li.dropdown>.dropdown-toggle .caret{border-top-color:#777;border-bottom-color:#777}.navbar .nav li.dropdown.open>.dropdown-toggle .caret,.navbar .nav li.dropdown.active>.dropdown-toggle .caret,.navbar .nav li.dropdown.open.active>.dropdown-toggle .caret{border-top-color:#555;border-bottom-color:#555}.navbar .pull-right>li>.dropdown-menu,.navbar .nav>li>.dropdown-menu.pull-right{right:0;left:auto}.navbar .pull-right>li>.dropdown-menu:before,.navbar .nav>li>.dropdown-menu.pull-right:before{right:12px;left:auto}.navbar .pull-right>li>.dropdown-menu:after,.navbar .nav>li>.dropdown-menu.pull-right:after{right:13px;left:auto}.navbar .pull-right>li>.dropdown-menu .dropdown-menu,.navbar .nav>li>.dropdown-menu.pull-right .dropdown-menu{right:100%;left:auto;margin-right:-1px;margin-left:0;-webkit-border-radius:6px 0 6px 6px;-moz-border-radius:6px 0 6px 6px;border-radius:6px 0 6px 6px}.navbar-inverse .navbar-inner{background-color:#1b1b1b;background-image:-moz-linear-gradient(top,#222,#111);background-image:-webkit-gradient(linear,0 0,0 100%,from(#222),to(#111));background-image:-webkit-linear-gradient(top,#222,#111);background-image:-o-linear-gradient(top,#222,#111);background-image:linear-gradient(to bottom,#222,#111);background-repeat:repeat-x;border-color:#252525;filter:progid:DXImageTransform.Microsoft.gradient(startColorstr='#ff222222',endColorstr='#ff111111',GradientType=0)}.navbar-inverse .brand,.navbar-inverse .nav>li>a{color:#999;text-shadow:0 -1px 0 rgba(0,0,0,0.25)}.navbar-inverse .brand:hover,.navbar-inverse .nav>li>a:hover{color:#fff}.navbar-inverse .brand{color:#999}.navbar-inverse .navbar-text{color:#999}.navbar-inverse .nav>li>a:focus,.navbar-inverse .nav>li>a:hover{color:#fff;background-color:transparent}.navbar-inverse .nav .active>a,.navbar-inverse .nav .active>a:hover,.navbar-inverse .nav .active>a:focus{color:#fff;background-color:#111}.navbar-inverse .navbar-link{color:#999}.navbar-inverse .navbar-link:hover{color:#fff}.navbar-inverse .divider-vertical{border-right-color:#222;border-left-color:#111}.navbar-inverse .nav li.dropdown.open>.dropdown-toggle,.navbar-inverse .nav li.dropdown.active>.dropdown-toggle,.navbar-inverse .nav li.dropdown.open.active>.dropdown-toggle{color:#fff;background-color:#111}.navbar-inverse .nav li.dropdown>a:hover .caret{border-top-color:#fff;border-bottom-color:#fff}.navbar-inverse .nav li.dropdown>.dropdown-toggle .caret{border-top-color:#999;border-bottom-color:#999}.navbar-inverse .nav li.dropdown.open>.dropdown-toggle .caret,.navbar-inverse .nav li.dropdown.active>.dropdown-toggle .caret,.navbar-inverse .nav li.dropdown.open.active>.dropdown-toggle .caret{border-top-color:#fff;border-bottom-color:#fff}.navbar-inverse .navbar-search .search-query{color:#fff;background-color:#515151;border-color:#111;-webkit-box-shadow:inset 0 1px 2px rgba(0,0,0,0.1),0 1px 0 rgba(255,255,255,0.15);-moz-box-shadow:inset 0 1px 2px rgba(0,0,0,0.1),0 1px 0 rgba(255,255,255,0.15);box-shadow:inset 0 1px 2px rgba(0,0,0,0.1),0 1px 0 rgba(255,255,255,0.15);-webkit-transition:none;-moz-transition:none;-o-transition:none;transition:none}.navbar-inverse .navbar-search .search-query:-moz-placeholder{color:#ccc}.navbar-inverse .navbar-search .search-query:-ms-input-placeholder{color:#ccc}.navbar-inverse .navbar-search .search-query::-webkit-input-placeholder{color:#ccc}.navbar-inverse .navbar-search .search-query:focus,.navbar-inverse .navbar-search .search-query.focused{padding:5px 15px;color:#333;text-shadow:0 1px 0 #fff;background-color:#fff;border:0;outline:0;-webkit-box-shadow:0 0 3px rgba(0,0,0,0.15);-moz-box-shadow:0 0 3px rgba(0,0,0,0.15);box-shadow:0 0 3px rgba(0,0,0,0.15)}.navbar-inverse .btn-navbar{color:#fff;text-shadow:0 -1px 0 rgba(0,0,0,0.25);background-color:#0e0e0e;*background-color:#040404;background-image:-moz-linear-gradient(top,#151515,#040404);background-image:-webkit-gradient(linear,0 0,0 100%,from(#151515),to(#040404));background-image:-webkit-linear-gradient(top,#151515,#040404);background-image:-o-linear-gradient(top,#151515,#040404);background-image:linear-gradient(to bottom,#151515,#040404);background-repeat:repeat-x;border-color:#040404 #040404 #000;border-color:rgba(0,0,0,0.1) rgba(0,0,0,0.1) rgba(0,0,0,0.25);filter:progid:DXImageTransform.Microsoft.gradient(startColorstr='#ff151515',endColorstr='#ff040404',GradientType=0);filter:progid:DXImageTransform.Microsoft.gradient(enabled=false)}.navbar-inverse .btn-navbar:hover,.navbar-inverse .btn-navbar:active,.navbar-inverse .btn-navbar.active,.navbar-inverse .btn-navbar.disabled,.navbar-inverse .btn-navbar[disabled]{color:#fff;background-color:#040404;*background-color:#000}.navbar-inverse .btn-navbar:active,.navbar-inverse .btn-navbar.active{background-color:#000 \9}.breadcrumb{padding:8px 15px;margin:0 0 20px;list-style:none;background-color:#f5f5f5;-webkit-border-radius:4px;-moz-border-radius:4px;border-radius:4px}.breadcrumb>li{display:inline-block;*display:inline;text-shadow:0 1px 0 #fff;*zoom:1}.breadcrumb>li>.divider{padding:0 5px;color:#ccc}.breadcrumb>.active{color:#999}.pagination{margin:20px 0}.pagination ul{display:inline-block;*display:inline;margin-bottom:0;margin-left:0;-webkit-border-radius:4px;-moz-border-radius:4px;border-radius:4px;*zoom:1;-webkit-box-shadow:0 1px 2px rgba(0,0,0,0.05);-moz-box-shadow:0 1px 2px rgba(0,0,0,0.05);box-shadow:0 1px 2px rgba(0,0,0,0.05)}.pagination ul>li{display:inline}.pagination ul>li>a,.pagination ul>li>span{float:left;padding:4px 12px;line-height:20px;text-decoration:none;background-color:#fff;border:1px solid #ddd;border-left-width:0}.pagination ul>li>a:hover,.pagination ul>.active>a,.pagination ul>.active>span{background-color:#f5f5f5}.pagination ul>.active>a,.pagination ul>.active>span{color:#999;cursor:default}.pagination ul>.disabled>span,.pagination ul>.disabled>a,.pagination ul>.disabled>a:hover{color:#999;cursor:default;background-color:transparent}.pagination ul>li:first-child>a,.pagination ul>li:first-child>span{border-left-width:1px;-webkit-border-bottom-left-radius:4px;border-bottom-left-radius:4px;-webkit-border-top-left-radius:4px;border-top-left-radius:4px;-moz-border-radius-bottomleft:4px;-moz-border-radius-topleft:4px}.pagination ul>li:last-child>a,.pagination ul>li:last-child>span{-webkit-border-top-right-radius:4px;border-top-right-radius:4px;-webkit-border-bottom-right-radius:4px;border-bottom-right-radius:4px;-moz-border-radius-topright:4px;-moz-border-radius-bottomright:4px}.pagination-centered{text-align:center}.pagination-right{text-align:right}.pagination-large ul>li>a,.pagination-large ul>li>span{padding:11px 19px;font-size:17.5px}.pagination-large ul>li:first-child>a,.pagination-large ul>li:first-child>span{-webkit-border-bottom-left-radius:6px;border-bottom-left-radius:6px;-webkit-border-top-left-radius:6px;border-top-left-radius:6px;-moz-border-radius-bottomleft:6px;-moz-border-radius-topleft:6px}.pagination-large ul>li:last-child>a,.pagination-large ul>li:last-child>span{-webkit-border-top-right-radius:6px;border-top-right-radius:6px;-webkit-border-bottom-right-radius:6px;border-bottom-right-radius:6px;-moz-border-radius-topright:6px;-moz-border-radius-bottomright:6px}.pagination-mini ul>li:first-child>a,.pagination-small ul>li:first-child>a,.pagination-mini ul>li:first-child>span,.pagination-small ul>li:first-child>span{-webkit-border-bottom-left-radius:3px;border-bottom-left-radius:3px;-webkit-border-top-left-radius:3px;border-top-left-radius:3px;-moz-border-radius-bottomleft:3px;-moz-border-radius-topleft:3px}.pagination-mini ul>li:last-child>a,.pagination-small ul>li:last-child>a,.pagination-mini ul>li:last-child>span,.pagination-small ul>li:last-child>span{-webkit-border-top-right-radius:3px;border-top-right-radius:3px;-webkit-border-bottom-right-radius:3px;border-bottom-right-radius:3px;-moz-border-radius-topright:3px;-moz-border-radius-bottomright:3px}.pagination-small ul>li>a,.pagination-small ul>li>span{padding:2px 10px;font-size:11.9px}.pagination-mini ul>li>a,.pagination-mini ul>li>span{padding:0 6px;font-size:10.5px}.pager{margin:20px 0;text-align:center;list-style:none;*zoom:1}.pager:before,.pager:after{display:table;line-height:0;content:""}.pager:after{clear:both}.pager li{display:inline}.pager li>a,.pager li>span{display:inline-block;padding:5px 14px;background-color:#fff;border:1px solid #ddd;-webkit-border-radius:15px;-moz-border-radius:15px;border-radius:15px}.pager li>a:hover{text-decoration:none;background-color:#f5f5f5}.pager .next>a,.pager .next>span{float:right}.pager .previous>a,.pager .previous>span{float:left}.pager .disabled>a,.pager .disabled>a:hover,.pager .disabled>span{color:#999;cursor:default;background-color:#fff}.modal-backdrop{position:fixed;top:0;right:0;bottom:0;left:0;z-index:1040;background-color:#000}.modal-backdrop.fade{opacity:0}.modal-backdrop,.modal-backdrop.fade.in{opacity:.8;filter:alpha(opacity=80)}.modal{position:fixed;top:10%;left:50%;z-index:1050;width:560px;margin-left:-280px;background-color:#fff;border:1px solid #999;border:1px solid rgba(0,0,0,0.3);*border:1px solid #999;-webkit-border-radius:6px;-moz-border-radius:6px;border-radius:6px;outline:0;-webkit-box-shadow:0 3px 7px rgba(0,0,0,0.3);-moz-box-shadow:0 3px 7px rgba(0,0,0,0.3);box-shadow:0 3px 7px rgba(0,0,0,0.3);-webkit-background-clip:padding-box;-moz-background-clip:padding-box;background-clip:padding-box}.modal.fade{top:-25%;-webkit-transition:opacity .3s linear,top .3s ease-out;-moz-transition:opacity .3s linear,top .3s ease-out;-o-transition:opacity .3s linear,top .3s ease-out;transition:opacity .3s linear,top .3s ease-out}.modal.fade.in{top:10%}.modal-header{padding:9px 15px;border-bottom:1px solid #eee}.modal-header .close{margin-top:2px}.modal-header h3{margin:0;line-height:30px}.modal-body{position:relative;max-height:400px;padding:15px;overflow-y:auto}.modal-form{margin-bottom:0}.modal-footer{padding:14px 15px 15px;margin-bottom:0;text-align:right;background-color:#f5f5f5;border-top:1px solid #ddd;-webkit-border-radius:0 0 6px 6px;-moz-border-radius:0 0 6px 6px;border-radius:0 0 6px 6px;*zoom:1;-webkit-box-shadow:inset 0 1px 0 #fff;-moz-box-shadow:inset 0 1px 0 #fff;box-shadow:inset 0 1px 0 #fff}.modal-footer:before,.modal-footer:after{display:table;line-height:0;content:""}.modal-footer:after{clear:both}.modal-footer .btn+.btn{margin-bottom:0;margin-left:5px}.modal-footer .btn-group .btn+.btn{margin-left:-1px}.modal-footer .btn-block+.btn-block{margin-left:0}.tooltip{position:absolute;z-index:1030;display:block;padding:5px;font-size:11px;opacity:0;filter:alpha(opacity=0);visibility:visible}.tooltip.in{opacity:.8;filter:alpha(opacity=80)}.tooltip.top{margin-top:-3px}.tooltip.right{margin-left:3px}.tooltip.bottom{margin-top:3px}.tooltip.left{margin-left:-3px}.tooltip-inner{max-width:200px;padding:3px 8px;color:#fff;text-align:center;text-decoration:none;background-color:#000;-webkit-border-radius:4px;-moz-border-radius:4px;border-radius:4px}.tooltip-arrow{position:absolute;width:0;height:0;border-color:transparent;border-style:solid}.tooltip.top .tooltip-arrow{bottom:0;left:50%;margin-left:-5px;border-top-color:#000;border-width:5px 5px 0}.tooltip.right .tooltip-arrow{top:50%;left:0;margin-top:-5px;border-right-color:#000;border-width:5px 5px 5px 0}.tooltip.left .tooltip-arrow{top:50%;right:0;margin-top:-5px;border-left-color:#000;border-width:5px 0 5px 5px}.tooltip.bottom .tooltip-arrow{top:0;left:50%;margin-left:-5px;border-bottom-color:#000;border-width:0 5px 5px}.popover{position:absolute;top:0;left:0;z-index:1010;display:none;width:236px;padding:1px;text-align:left;white-space:normal;background-color:#fff;border:1px solid #ccc;border:1px solid rgba(0,0,0,0.2);-webkit-border-radius:6px;-moz-border-radius:6px;border-radius:6px;-webkit-box-shadow:0 5px 10px rgba(0,0,0,0.2);-moz-box-shadow:0 5px 10px rgba(0,0,0,0.2);box-shadow:0 5px 10px rgba(0,0,0,0.2);-webkit-background-clip:padding-box;-moz-background-clip:padding;background-clip:padding-box}.popover.top{margin-top:-10px}.popover.right{margin-left:10px}.popover.bottom{margin-top:10px}.popover.left{margin-left:-10px}.popover-title{padding:8px 14px;margin:0;font-size:14px;font-weight:normal;line-height:18px;background-color:#f7f7f7;border-bottom:1px solid #ebebeb;-webkit-border-radius:5px 5px 0 0;-moz-border-radius:5px 5px 0 0;border-radius:5px 5px 0 0}.popover-content{padding:9px 14px}.popover .arrow,.popover .arrow:after{position:absolute;display:block;width:0;height:0;border-color:transparent;border-style:solid}.popover .arrow{border-width:11px}.popover .arrow:after{border-width:10px;content:""}.popover.top .arrow{bottom:-11px;left:50%;margin-left:-11px;border-top-color:#999;border-top-color:rgba(0,0,0,0.25);border-bottom-width:0}.popover.top .arrow:after{bottom:1px;margin-left:-10px;border-top-color:#fff;border-bottom-width:0}.popover.right .arrow{top:50%;left:-11px;margin-top:-11px;border-right-color:#999;border-right-color:rgba(0,0,0,0.25);border-left-width:0}.popover.right .arrow:after{bottom:-10px;left:1px;border-right-color:#fff;border-left-width:0}.popover.bottom .arrow{top:-11px;left:50%;margin-left:-11px;border-bottom-color:#999;border-bottom-color:rgba(0,0,0,0.25);border-top-width:0}.popover.bottom .arrow:after{top:1px;margin-left:-10px;border-bottom-color:#fff;border-top-width:0}.popover.left .arrow{top:50%;right:-11px;margin-top:-11px;border-left-color:#999;border-left-color:rgba(0,0,0,0.25);border-right-width:0}.popover.left .arrow:after{right:1px;bottom:-10px;border-left-color:#fff;border-right-width:0}.thumbnails{margin-left:-20px;list-style:none;*zoom:1}.thumbnails:before,.thumbnails:after{display:table;line-height:0;content:""}.thumbnails:after{clear:both}.row-fluid .thumbnails{margin-left:0}.thumbnails>li{float:left;margin-bottom:20px;margin-left:20px}.thumbnail{display:block;padding:4px;line-height:20px;border:1px solid #ddd;-webkit-border-radius:4px;-moz-border-radius:4px;border-radius:4px;-webkit-box-shadow:0 1px 3px rgba(0,0,0,0.055);-moz-box-shadow:0 1px 3px rgba(0,0,0,0.055);box-shadow:0 1px 3px rgba(0,0,0,0.055);-webkit-transition:all .2s ease-in-out;-moz-transition:all .2s ease-in-out;-o-transition:all .2s ease-in-out;transition:all .2s ease-in-out}a.thumbnail:hover{border-color:#08c;-webkit-box-shadow:0 1px 4px rgba(0,105,214,0.25);-moz-box-shadow:0 1px 4px rgba(0,105,214,0.25);box-shadow:0 1px 4px rgba(0,105,214,0.25)}.thumbnail>img{display:block;max-width:100%;margin-right:auto;margin-left:auto}.thumbnail .caption{padding:9px;color:#555}.media,.media-body{overflow:hidden;*overflow:visible;zoom:1}.media,.media .media{margin-top:15px}.media:first-child{margin-top:0}.media-object{display:block}.media-heading{margin:0 0 5px}.media .pull-left{margin-right:10px}.media .pull-right{margin-left:10px}.media-list{margin-left:0;list-style:none}.label,.badge{display:inline-block;padding:2px 4px;font-size:11.844px;font-weight:bold;line-height:14px;color:#fff;text-shadow:0 -1px 0 rgba(0,0,0,0.25);white-space:nowrap;vertical-align:baseline;background-color:#999}.label{-webkit-border-radius:3px;-moz-border-radius:3px;border-radius:3px}.badge{padding-right:9px;padding-left:9px;-webkit-border-radius:9px;-moz-border-radius:9px;border-radius:9px}.label:empty,.badge:empty{display:none}a.label:hover,a.badge:hover{color:#fff;text-decoration:none;cursor:pointer}.label-important,.badge-important{background-color:#b94a48}.label-important[href],.badge-important[href]{background-color:#953b39}.label-warning,.badge-warning{background-color:#f89406}.label-warning[href],.badge-warning[href]{background-color:#c67605}.label-success,.badge-success{background-color:#468847}.label-success[href],.badge-success[href]{background-color:#356635}.label-info,.badge-info{background-color:#3a87ad}.label-info[href],.badge-info[href]{background-color:#2d6987}.label-inverse,.badge-inverse{background-color:#333}.label-inverse[href],.badge-inverse[href]{background-color:#1a1a1a}.btn .label,.btn .badge{position:relative;top:-1px}.btn-mini .label,.btn-mini .badge{top:0}@-webkit-keyframes progress-bar-stripes{from{background-position:40px 0}to{background-position:0 0}}@-moz-keyframes progress-bar-stripes{from{background-position:40px 0}to{background-position:0 0}}@-ms-keyframes progress-bar-stripes{from{background-position:40px 0}to{background-position:0 0}}@-o-keyframes progress-bar-stripes{from{background-position:0 0}to{background-position:40px 0}}@keyframes progress-bar-stripes{from{background-position:40px 0}to{background-position:0 0}}.progress{height:20px;margin-bottom:20px;overflow:hidden;background-color:#f7f7f7;background-image:-moz-linear-gradient(top,#f5f5f5,#f9f9f9);background-image:-webkit-gradient(linear,0 0,0 100%,from(#f5f5f5),to(#f9f9f9));background-image:-webkit-linear-gradient(top,#f5f5f5,#f9f9f9);background-image:-o-linear-gradient(top,#f5f5f5,#f9f9f9);background-image:linear-gradient(to bottom,#f5f5f5,#f9f9f9);background-repeat:repeat-x;-webkit-border-radius:4px;-moz-border-radius:4px;border-radius:4px;filter:progid:DXImageTransform.Microsoft.gradient(startColorstr='#fff5f5f5',endColorstr='#fff9f9f9',GradientType=0);-webkit-box-shadow:inset 0 1px 2px rgba(0,0,0,0.1);-moz-box-shadow:inset 0 1px 2px rgba(0,0,0,0.1);box-shadow:inset 0 1px 2px rgba(0,0,0,0.1)}.progress .bar{float:left;width:0;height:100%;font-size:12px;color:#fff;text-align:center;text-shadow:0 -1px 0 rgba(0,0,0,0.25);background-color:#0e90d2;background-image:-moz-linear-gradient(top,#149bdf,#0480be);background-image:-webkit-gradient(linear,0 0,0 100%,from(#149bdf),to(#0480be));background-image:-webkit-linear-gradient(top,#149bdf,#0480be);background-image:-o-linear-gradient(top,#149bdf,#0480be);background-image:linear-gradient(to bottom,#149bdf,#0480be);background-repeat:repeat-x;filter:progid:DXImageTransform.Microsoft.gradient(startColorstr='#ff149bdf',endColorstr='#ff0480be',GradientType=0);-webkit-box-shadow:inset 0 -1px 0 rgba(0,0,0,0.15);-moz-box-shadow:inset 0 -1px 0 rgba(0,0,0,0.15);box-shadow:inset 0 -1px 0 rgba(0,0,0,0.15);-webkit-box-sizing:border-box;-moz-box-sizing:border-box;box-sizing:border-box;-webkit-transition:width .6s ease;-moz-transition:width .6s ease;-o-transition:width .6s ease;transition:width .6s ease}.progress .bar+.bar{-webkit-box-shadow:inset 1px 0 0 rgba(0,0,0,0.15),inset 0 -1px 0 rgba(0,0,0,0.15);-moz-box-shadow:inset 1px 0 0 rgba(0,0,0,0.15),inset 0 -1px 0 rgba(0,0,0,0.15);box-shadow:inset 1px 0 0 rgba(0,0,0,0.15),inset 0 -1px 0 rgba(0,0,0,0.15)}.progress-striped .bar{background-color:#149bdf;background-image:-webkit-gradient(linear,0 100%,100% 0,color-stop(0.25,rgba(255,255,255,0.15)),color-stop(0.25,transparent),color-stop(0.5,transparent),color-stop(0.5,rgba(255,255,255,0.15)),color-stop(0.75,rgba(255,255,255,0.15)),color-stop(0.75,transparent),to(transparent));background-image:-webkit-linear-gradient(45deg,rgba(255,255,255,0.15) 25%,transparent 25%,transparent 50%,rgba(255,255,255,0.15) 50%,rgba(255,255,255,0.15) 75%,transparent 75%,transparent);background-image:-moz-linear-gradient(45deg,rgba(255,255,255,0.15) 25%,transparent 25%,transparent 50%,rgba(255,255,255,0.15) 50%,rgba(255,255,255,0.15) 75%,transparent 75%,transparent);background-image:-o-linear-gradient(45deg,rgba(255,255,255,0.15) 25%,transparent 25%,transparent 50%,rgba(255,255,255,0.15) 50%,rgba(255,255,255,0.15) 75%,transparent 75%,transparent);background-image:linear-gradient(45deg,rgba(255,255,255,0.15) 25%,transparent 25%,transparent 50%,rgba(255,255,255,0.15) 50%,rgba(255,255,255,0.15) 75%,transparent 75%,transparent);-webkit-background-size:40px 40px;-moz-background-size:40px 40px;-o-background-size:40px 40px;background-size:40px 40px}.progress.active .bar{-webkit-animation:progress-bar-stripes 2s linear infinite;-moz-animation:progress-bar-stripes 2s linear infinite;-ms-animation:progress-bar-stripes 2s linear infinite;-o-animation:progress-bar-stripes 2s linear infinite;animation:progress-bar-stripes 2s linear infinite}.progress-danger .bar,.progress .bar-danger{background-color:#dd514c;background-image:-moz-linear-gradient(top,#ee5f5b,#c43c35);background-image:-webkit-gradient(linear,0 0,0 100%,from(#ee5f5b),to(#c43c35));background-image:-webkit-linear-gradient(top,#ee5f5b,#c43c35);background-image:-o-linear-gradient(top,#ee5f5b,#c43c35);background-image:linear-gradient(to bottom,#ee5f5b,#c43c35);background-repeat:repeat-x;filter:progid:DXImageTransform.Microsoft.gradient(startColorstr='#ffee5f5b',endColorstr='#ffc43c35',GradientType=0)}.progress-danger.progress-striped .bar,.progress-striped .bar-danger{background-color:#ee5f5b;background-image:-webkit-gradient(linear,0 100%,100% 0,color-stop(0.25,rgba(255,255,255,0.15)),color-stop(0.25,transparent),color-stop(0.5,transparent),color-stop(0.5,rgba(255,255,255,0.15)),color-stop(0.75,rgba(255,255,255,0.15)),color-stop(0.75,transparent),to(transparent));background-image:-webkit-linear-gradient(45deg,rgba(255,255,255,0.15) 25%,transparent 25%,transparent 50%,rgba(255,255,255,0.15) 50%,rgba(255,255,255,0.15) 75%,transparent 75%,transparent);background-image:-moz-linear-gradient(45deg,rgba(255,255,255,0.15) 25%,transparent 25%,transparent 50%,rgba(255,255,255,0.15) 50%,rgba(255,255,255,0.15) 75%,transparent 75%,transparent);background-image:-o-linear-gradient(45deg,rgba(255,255,255,0.15) 25%,transparent 25%,transparent 50%,rgba(255,255,255,0.15) 50%,rgba(255,255,255,0.15) 75%,transparent 75%,transparent);background-image:linear-gradient(45deg,rgba(255,255,255,0.15) 25%,transparent 25%,transparent 50%,rgba(255,255,255,0.15) 50%,rgba(255,255,255,0.15) 75%,transparent 75%,transparent)}.progress-success .bar,.progress .bar-success{background-color:#5eb95e;background-image:-moz-linear-gradient(top,#62c462,#57a957);background-image:-webkit-gradient(linear,0 0,0 100%,from(#62c462),to(#57a957));background-image:-webkit-linear-gradient(top,#62c462,#57a957);background-image:-o-linear-gradient(top,#62c462,#57a957);background-image:linear-gradient(to bottom,#62c462,#57a957);background-repeat:repeat-x;filter:progid:DXImageTransform.Microsoft.gradient(startColorstr='#ff62c462',endColorstr='#ff57a957',GradientType=0)}.progress-success.progress-striped .bar,.progress-striped .bar-success{background-color:#62c462;background-image:-webkit-gradient(linear,0 100%,100% 0,color-stop(0.25,rgba(255,255,255,0.15)),color-stop(0.25,transparent),color-stop(0.5,transparent),color-stop(0.5,rgba(255,255,255,0.15)),color-stop(0.75,rgba(255,255,255,0.15)),color-stop(0.75,transparent),to(transparent));background-image:-webkit-linear-gradient(45deg,rgba(255,255,255,0.15) 25%,transparent 25%,transparent 50%,rgba(255,255,255,0.15) 50%,rgba(255,255,255,0.15) 75%,transparent 75%,transparent);background-image:-moz-linear-gradient(45deg,rgba(255,255,255,0.15) 25%,transparent 25%,transparent 50%,rgba(255,255,255,0.15) 50%,rgba(255,255,255,0.15) 75%,transparent 75%,transparent);background-image:-o-linear-gradient(45deg,rgba(255,255,255,0.15) 25%,transparent 25%,transparent 50%,rgba(255,255,255,0.15) 50%,rgba(255,255,255,0.15) 75%,transparent 75%,transparent);background-image:linear-gradient(45deg,rgba(255,255,255,0.15) 25%,transparent 25%,transparent 50%,rgba(255,255,255,0.15) 50%,rgba(255,255,255,0.15) 75%,transparent 75%,transparent)}.progress-info .bar,.progress .bar-info{background-color:#4bb1cf;background-image:-moz-linear-gradient(top,#5bc0de,#339bb9);background-image:-webkit-gradient(linear,0 0,0 100%,from(#5bc0de),to(#339bb9));background-image:-webkit-linear-gradient(top,#5bc0de,#339bb9);background-image:-o-linear-gradient(top,#5bc0de,#339bb9);background-image:linear-gradient(to bottom,#5bc0de,#339bb9);background-repeat:repeat-x;filter:progid:DXImageTransform.Microsoft.gradient(startColorstr='#ff5bc0de',endColorstr='#ff339bb9',GradientType=0)}.progress-info.progress-striped .bar,.progress-striped .bar-info{background-color:#5bc0de;background-image:-webkit-gradient(linear,0 100%,100% 0,color-stop(0.25,rgba(255,255,255,0.15)),color-stop(0.25,transparent),color-stop(0.5,transparent),color-stop(0.5,rgba(255,255,255,0.15)),color-stop(0.75,rgba(255,255,255,0.15)),color-stop(0.75,transparent),to(transparent));background-image:-webkit-linear-gradient(45deg,rgba(255,255,255,0.15) 25%,transparent 25%,transparent 50%,rgba(255,255,255,0.15) 50%,rgba(255,255,255,0.15) 75%,transparent 75%,transparent);background-image:-moz-linear-gradient(45deg,rgba(255,255,255,0.15) 25%,transparent 25%,transparent 50%,rgba(255,255,255,0.15) 50%,rgba(255,255,255,0.15) 75%,transparent 75%,transparent);background-image:-o-linear-gradient(45deg,rgba(255,255,255,0.15) 25%,transparent 25%,transparent 50%,rgba(255,255,255,0.15) 50%,rgba(255,255,255,0.15) 75%,transparent 75%,transparent);background-image:linear-gradient(45deg,rgba(255,255,255,0.15) 25%,transparent 25%,transparent 50%,rgba(255,255,255,0.15) 50%,rgba(255,255,255,0.15) 75%,transparent 75%,transparent)}.progress-warning .bar,.progress .bar-warning{background-color:#faa732;background-image:-moz-linear-gradient(top,#fbb450,#f89406);background-image:-webkit-gradient(linear,0 0,0 100%,from(#fbb450),to(#f89406));background-image:-webkit-linear-gradient(top,#fbb450,#f89406);background-image:-o-linear-gradient(top,#fbb450,#f89406);background-image:linear-gradient(to bottom,#fbb450,#f89406);background-repeat:repeat-x;filter:progid:DXImageTransform.Microsoft.gradient(startColorstr='#fffbb450',endColorstr='#fff89406',GradientType=0)}.progress-warning.progress-striped .bar,.progress-striped .bar-warning{background-color:#fbb450;background-image:-webkit-gradient(linear,0 100%,100% 0,color-stop(0.25,rgba(255,255,255,0.15)),color-stop(0.25,transparent),color-stop(0.5,transparent),color-stop(0.5,rgba(255,255,255,0.15)),color-stop(0.75,rgba(255,255,255,0.15)),color-stop(0.75,transparent),to(transparent));background-image:-webkit-linear-gradient(45deg,rgba(255,255,255,0.15) 25%,transparent 25%,transparent 50%,rgba(255,255,255,0.15) 50%,rgba(255,255,255,0.15) 75%,transparent 75%,transparent);background-image:-moz-linear-gradient(45deg,rgba(255,255,255,0.15) 25%,transparent 25%,transparent 50%,rgba(255,255,255,0.15) 50%,rgba(255,255,255,0.15) 75%,transparent 75%,transparent);background-image:-o-linear-gradient(45deg,rgba(255,255,255,0.15) 25%,transparent 25%,transparent 50%,rgba(255,255,255,0.15) 50%,rgba(255,255,255,0.15) 75%,transparent 75%,transparent);background-image:linear-gradient(45deg,rgba(255,255,255,0.15) 25%,transparent 25%,transparent 50%,rgba(255,255,255,0.15) 50%,rgba(255,255,255,0.15) 75%,transparent 75%,transparent)}.accordion{margin-bottom:20px}.accordion-group{margin-bottom:2px;border:1px solid #e5e5e5;-webkit-border-radius:4px;-moz-border-radius:4px;border-radius:4px}.accordion-heading{border-bottom:0}.accordion-heading .accordion-toggle{display:block;padding:8px 15px}.accordion-toggle{cursor:pointer}.accordion-inner{padding:9px 15px;border-top:1px solid #e5e5e5}.carousel{position:relative;margin-bottom:20px;line-height:1}.carousel-inner{position:relative;width:100%;overflow:hidden}.carousel-inner>.item{position:relative;display:none;-webkit-transition:.6s ease-in-out left;-moz-transition:.6s ease-in-out left;-o-transition:.6s ease-in-out left;transition:.6s ease-in-out left}.carousel-inner>.item>img{display:block;line-height:1}.carousel-inner>.active,.carousel-inner>.next,.carousel-inner>.prev{display:block}.carousel-inner>.active{left:0}.carousel-inner>.next,.carousel-inner>.prev{position:absolute;top:0;width:100%}.carousel-inner>.next{left:100%}.carousel-inner>.prev{left:-100%}.carousel-inner>.next.left,.carousel-inner>.prev.right{left:0}.carousel-inner>.active.left{left:-100%}.carousel-inner>.active.right{left:100%}.carousel-control{position:absolute;top:40%;left:15px;width:40px;height:40px;margin-top:-20px;font-size:60px;font-weight:100;line-height:30px;color:#fff;text-align:center;background:#222;border:3px solid #fff;-webkit-border-radius:23px;-moz-border-radius:23px;border-radius:23px;opacity:.5;filter:alpha(opacity=50)}.carousel-control.right{right:15px;left:auto}.carousel-control:hover{color:#fff;text-decoration:none;opacity:.9;filter:alpha(opacity=90)}.carousel-caption{position:absolute;right:0;bottom:0;left:0;padding:15px;background:#333;background:rgba(0,0,0,0.75)}.carousel-caption h4,.carousel-caption p{line-height:20px;color:#fff}.carousel-caption h4{margin:0 0 5px}.carousel-caption p{margin-bottom:0}.hero-unit{padding:60px;margin-bottom:30px;font-size:18px;font-weight:200;line-height:30px;color:inherit;background-color:#eee;-webkit-border-radius:6px;-moz-border-radius:6px;border-radius:6px}.hero-unit h1{margin-bottom:0;font-size:60px;line-height:1;letter-spacing:-1px;color:inherit}.hero-unit li{line-height:30px}.pull-right{float:right}.pull-left{float:left}.hide{display:none}.show{display:block}.invisible{visibility:hidden}.affix{position:fixed} diff --git a/website/css/footer.css b/website/css/footer.css new file mode 100644 index 00000000..10803437 --- /dev/null +++ b/website/css/footer.css @@ -0,0 +1,23 @@ +/* Footer +-------------------------------------------------- */ + +.footer { + padding: 70px 0px 70px 0px; + margin-top: 70px; + border-top: 1px solid #e5e5e5; + background-color: #f5f5f5; +} +.footer p { + margin-bottom: 0; + color: #777; +} +.footer-links { + margin: 10px 0; +} +.footer-links li { + display: inline; + padding: 0 2px; +} +.footer-links li:first-child { + padding-left: 0; +} diff --git a/website/css/nav.css b/website/css/nav.css new file mode 100644 index 00000000..091142cd --- /dev/null +++ b/website/css/nav.css @@ -0,0 +1,26 @@ +/* Remove border and change up box shadow for more contrast */ +.navbar .navbar-inner { + border: 0; + -webkit-box-shadow: 0 2px 10px rgba(0,0,0,.25); + -moz-box-shadow: 0 2px 10px rgba(0,0,0,.25); + box-shadow: 0 2px 10px rgba(0,0,0,.25); +} + +/* Downsize the brand/project name a bit */ +.navbar .brand { + padding: 14px 20px 16px; /* Increase vertical padding to match navbar links */ + font-size: 16px; + font-weight: bold; + text-shadow: 0 -1px 0 rgba(0,0,0,.5); +} + +/* Navbar links: increase padding for taller navbar */ +.navbar .nav > li > a { + padding: 15px 20px; +} + +/* Offset the responsive button for proper vertical alignment */ +.navbar .btn-navbar { + margin-top: 10px; +} + diff --git a/website/css/page.css b/website/css/page.css new file mode 100644 index 00000000..77fcb2ec --- /dev/null +++ b/website/css/page.css @@ -0,0 +1,20 @@ +body { +/* padding: 40px 20px; */ + color: #555; + text-shadow: 0 1px 0 #fff; + background-color: #fff; + background-image: -webkit-gradient(linear, 0 0, 0 100%, from(#eee), color-stop(25%, #fff), to(#fff)); + background-image: -webkit-linear-gradient(#eee, #fff 25%, #fff); + background-image: -moz-linear-gradient(top, #eee, #fff 25%, #fff); + background-image: -ms-linear-gradient(#eee, #fff 25%, #fff); + background-image: -o-linear-gradient(#eee, #fff 25%, #fff); + background-image: linear-gradient(#eee, #fff 25%, #fff); + background-repeat: no-repeat; + background-attachment: fixed; + overflow: auto; +} + +h3 { + padding-top: 40px; + +} diff --git a/website/css/pygments.css b/website/css/pygments.css new file mode 100644 index 00000000..122b4294 --- /dev/null +++ b/website/css/pygments.css @@ -0,0 +1,61 @@ +.hll { background-color: #ffffcc } +.c { color: #408080; font-style: italic } /* Comment */ +.err { border: 1px solid #FF0000 } /* Error */ +.k { color: #008000; font-weight: bold } /* Keyword */ +.o { color: #666666 } /* Operator */ +.cm { color: #408080; font-style: italic } /* Comment.Multiline */ +.cp { color: #BC7A00 } /* Comment.Preproc */ +.c1 { color: #408080; font-style: italic } /* Comment.Single */ +.cs { color: #408080; font-style: italic } /* Comment.Special */ +.gd { color: #A00000 } /* Generic.Deleted */ +.ge { font-style: italic } /* Generic.Emph */ +.gr { color: #FF0000 } /* Generic.Error */ +.gh { color: #000080; font-weight: bold } /* Generic.Heading */ +.gi { color: #00A000 } /* Generic.Inserted */ +.go { color: #808080 } /* Generic.Output */ +.gp { color: #000080; font-weight: bold } /* Generic.Prompt */ +.gs { font-weight: bold } /* Generic.Strong */ +.gu { color: #800080; font-weight: bold } /* Generic.Subheading */ +.gt { color: #0040D0 } /* Generic.Traceback */ +.kc { color: #008000; font-weight: bold } /* Keyword.Constant */ +.kd { color: #008000; font-weight: bold } /* Keyword.Declaration */ +.kn { color: #008000; font-weight: bold } /* Keyword.Namespace */ +.kp { color: #008000 } /* Keyword.Pseudo */ +.kr { color: #008000; font-weight: bold } /* Keyword.Reserved */ +.kt { color: #B00040 } /* Keyword.Type */ +.m { color: #666666 } /* Literal.Number */ +.s { color: #BA2121 } /* Literal.String */ +.na { color: #7D9029 } /* Name.Attribute */ +.nb { color: #008000 } /* Name.Builtin */ +.nc { color: #0000FF; font-weight: bold } /* Name.Class */ +.no { color: #880000 } /* Name.Constant */ +.nd { color: #AA22FF } /* Name.Decorator */ +.ni { color: #999999; font-weight: bold } /* Name.Entity */ +.ne { color: #D2413A; font-weight: bold } /* Name.Exception */ +.nf { color: #0000FF } /* Name.Function */ +.nl { color: #A0A000 } /* Name.Label */ +.nn { color: #0000FF; font-weight: bold } /* Name.Namespace */ +.nt { color: #008000; font-weight: bold } /* Name.Tag */ +.nv { color: #19177C } /* Name.Variable */ +.ow { color: #AA22FF; font-weight: bold } /* Operator.Word */ +.w { color: #bbbbbb } /* Text.Whitespace */ +.mf { color: #666666 } /* Literal.Number.Float */ +.mh { color: #666666 } /* Literal.Number.Hex */ +.mi { color: #666666 } /* Literal.Number.Integer */ +.mo { color: #666666 } /* Literal.Number.Oct */ +.sb { color: #BA2121 } /* Literal.String.Backtick */ +.sc { color: #BA2121 } /* Literal.String.Char */ +.sd { color: #BA2121; font-style: italic } /* Literal.String.Doc */ +.s2 { color: #BA2121 } /* Literal.String.Double */ +.se { color: #BB6622; font-weight: bold } /* Literal.String.Escape */ +.sh { color: #BA2121 } /* Literal.String.Heredoc */ +.si { color: #BB6688; font-weight: bold } /* Literal.String.Interpol */ +.sx { color: #008000 } /* Literal.String.Other */ +.sr { color: #BB6688 } /* Literal.String.Regex */ +.s1 { color: #BA2121 } /* Literal.String.Single */ +.ss { color: #19177C } /* Literal.String.Symbol */ +.bp { color: #008000 } /* Name.Builtin.Pseudo */ +.vc { color: #19177C } /* Name.Variable.Class */ +.vg { color: #19177C } /* Name.Variable.Global */ +.vi { color: #19177C } /* Name.Variable.Instance */ +.il { color: #666666 } /* Literal.Number.Integer.Long */ diff --git a/website/css/sidenav.css b/website/css/sidenav.css new file mode 100644 index 00000000..0bd93f95 --- /dev/null +++ b/website/css/sidenav.css @@ -0,0 +1,157 @@ +.sidenav { + width: 228px; + margin: 30px 0 0; + padding: 0; + background-color: #fff; + -webkit-border-radius: 6px; + -moz-border-radius: 6px; + border-radius: 6px; + -webkit-box-shadow: 0 1px 4px rgba(0,0,0,.065); + -moz-box-shadow: 0 1px 4px rgba(0,0,0,.065); + box-shadow: 0 1px 4px rgba(0,0,0,.065); +} +.sidenav > li > a { + display: block; + width: 190px \9; + margin: 0 0 -1px; + padding: 8px 14px; + border: 1px solid #e5e5e5; +} +.sidenav > li:first-child > a { + -webkit-border-radius: 6px 6px 0 0; + -moz-border-radius: 6px 6px 0 0; + border-radius: 6px 6px 0 0; +} +.sidenav > li:last-child > a { + -webkit-border-radius: 0 0 6px 6px; + -moz-border-radius: 0 0 6px 6px; + border-radius: 0 0 6px 6px; +} +.sidenav > .active > a { + position: relative; + z-index: 2; + padding: 9px 15px; + border: 0; + text-shadow: 0 1px 0 rgba(0,0,0,.15); + -webkit-box-shadow: inset 1px 0 0 rgba(0,0,0,.1), inset -1px 0 0 rgba(0,0,0,.1); + -moz-box-shadow: inset 1px 0 0 rgba(0,0,0,.1), inset -1px 0 0 rgba(0,0,0,.1); + box-shadow: inset 1px 0 0 rgba(0,0,0,.1), inset -1px 0 0 rgba(0,0,0,.1); +} + +/* Chevrons */ +.sidenav .icon-chevron-right { + float: right; + margin-top: 2px; + margin-right: -6px; + opacity: .25; +} +.sidenav > li > a:hover { + background-color: #f5f5f5; +} +.sidenav a:hover .icon-chevron-right { + opacity: .5; +} +.sidenav .active .icon-chevron-right, +.sidenav .active a:hover .icon-chevron-right { + background-image: url(../img/glyphicons-halflings-white.png); + opacity: 1; +} + + +/* +.sidenav.affix-bottom { + position: absolute; + top: auto; + bottom: 270px; +} +*/ + + +/* Responsive +-------------------------------------------------- */ + +/* Desktop large +------------------------- */ +@media (min-width: 1200px) { + .sidenav { + width: 258px; + top: 0; + margin-top: 30px; + margin-right: 0; + } + .sidenav > li > a { + width: 230px \9; /* Override the previous IE8-9 hack */ + } +} + +/* Desktop +------------------------- */ +@media (max-width: 980px) { + /* Unfloat brand */ + body > .navbar-fixed-top .brand { + float: left; + margin-left: 0; + padding-left: 10px; + padding-right: 10px; + } + + /* When affixed, space properly */ + .sidenav { + top: 0; + width: 218px; + margin-top: 30px; + margin-right: 0; + } +} + +/* Tablet to desktop +------------------------- */ +@media (min-width: 768px) and (max-width: 979px) { + /* Remove any padding from the body */ + body { + padding-top: 0; + } + /* Adjust sidenav width */ + .sidenav { + width: 166px; + margin-top: 20px; + } + .sidenav.affix { + top: 0; + } +} +@media (max-width:767px) { + .sidenav { + visibility: hidden + } +} + +/* Tablet +------------------------- */ +@media (max-width: 767px) { + /* Remove any padding from the body */ + body { + padding-top: 0; + } + + /* Sidenav */ + .sidenav { + width: auto; + margin-bottom: 20px; + } + /* + .sidenav.affix { + position: static; + width: auto; + top: 0; + } */ +} + +/* Landscape phones +------------------------- */ +@media (max-width: 480px) { + /* Remove padding above jumbotron */ + body { + padding-top: 0; + } +} diff --git a/website/css/site.css b/website/css/site.css new file mode 100644 index 00000000..06ed7fb9 --- /dev/null +++ b/website/css/site.css @@ -0,0 +1,171 @@ + /* GLOBAL STYLES + -------------------------------------------------- */ + /* Padding below the footer and lighter body text */ + + body { + color: #5a5a5a; + } + + + + /* CUSTOMIZE THE NAVBAR + -------------------------------------------------- */ + + /* Special class on .container surrounding .navbar, used for positioning it into place. */ + .navbar-wrapper { + position: relative; + z-index: 10; + margin-top: 20px; + margin-bottom: -90px; /* Negative margin to pull up carousel. 90px is roughly margins and height of navbar. */ + } + + /* Remove border and change up box shadow for more contrast */ + .navbar .navbar-inner { + border: 0; + -webkit-box-shadow: 0 2px 10px rgba(0,0,0,.25); + -moz-box-shadow: 0 2px 10px rgba(0,0,0,.25); + box-shadow: 0 2px 10px rgba(0,0,0,.25); + } + + /* Downsize the brand/project name a bit */ + .navbar .brand { + padding: 14px 20px 16px; /* Increase vertical padding to match navbar links */ + font-size: 16px; + font-weight: bold; + text-shadow: 0 -1px 0 rgba(0,0,0,.5); + } + + /* Navbar links: increase padding for taller navbar */ + .navbar .nav > li > a { + padding: 15px 20px; + } + + /* Offset the responsive button for proper vertical alignment */ + .navbar .btn-navbar { + margin-top: 10px; + } + + /* CUSTOMIZE THE NAVBAR + -------------------------------------------------- */ + + /* Carousel base class */ + .carousel { + margin-bottom: 60px; + } + + .carousel .container { + position: absolute; + right: 0; + bottom: 0; + left: 0; + } + + .carousel-control { + background-color: transparent; + border: 0; + font-size: 120px; + margin-top: 0; + text-shadow: 0 1px 1px rgba(0,0,0,.4); + } + + .carousel .item { + height: 500px; + } + .carousel img { + min-width: 100%; + height: 500px; + } + + .carousel-caption { + background-color: transparent; + position: static; + max-width: 550px; + padding: 0 20px; + margin-bottom: 100px; + } + .carousel-caption h1, + .carousel-caption .lead { + margin: 0; + line-height: 1.25; + color: #fff; + text-shadow: 0 1px 1px rgba(0,0,0,.4); + } + .carousel-caption .btn { + margin-top: 10px; + } + + /* MARKETING CONTENT + -------------------------------------------------- */ + + /* Center align the text within the three columns below the carousel */ + .marketing .span4 { + text-align: center; + } + .marketing h2 { + font-weight: normal; + } + .marketing .span4 p { + margin-left: 10px; + margin-right: 10px; + } + + /* RESPONSIVE CSS + -------------------------------------------------- */ + + @media (max-width: 979px) { + + .container.navbar-wrapper { + margin-bottom: 0; + width: auto; + } + .navbar-inner { + border-radius: 0; + margin: -20px 0; + } + + .carousel .item { + height: 500px; + } + .carousel img { + width: auto; + height: 500px; + } + } + + + @media (max-width: 767px) { + + .navbar-inner { + margin: -20px; + } + + .carousel { + margin-left: -20px; + margin-right: -20px; + } + .carousel .container { + + } + .carousel .item { + height: 300px; + } + .carousel img { + height: 300px; + } + .carousel-caption { + width: 65%; + padding: 0 70px; + margin-bottom: 40px; + } + .carousel-caption h1 { + font-size: 30px; + } + .carousel-caption .lead, + .carousel-caption .btn { + font-size: 18px; + } + + .marketing .span4 + .span4 { + margin-top: 40px; + } + } diff --git a/website/css/social.css b/website/css/social.css new file mode 100644 index 00000000..e30b7657 --- /dev/null +++ b/website/css/social.css @@ -0,0 +1,31 @@ +/* Social proof buttons from GitHub & Twitter */ +.social { + padding: 15px 0; + text-align: center; + background-color: #f5f5f5; + border-top: 1px solid #fff; + border-bottom: 1px solid #ddd; + margin-top: -60px; +} + +/* Quick links on Home */ +.social-buttons { + margin-left: 0; + margin-bottom: 0; + padding-left: 0; + list-style: none; +} +.social-buttons li { + display: inline-block; + padding: 5px 8px; + line-height: 1; + *display: inline; + *zoom: 1; +} + + +@media (max-width: 767px) { + .social { + margin: 0 -20px; + } +} diff --git a/website/documentation.md b/website/documentation.md new file mode 100644 index 00000000..b59ed15e --- /dev/null +++ b/website/documentation.md @@ -0,0 +1,536 @@ +--- +layout: documentation +title: Documentation +--- + +### Cloud Haskell Platform + +This is the [*Cloud Haskell Platform*][cloud-haskell]. Cloud Haskell is a set of libraries +that bring Erlang-style concurrency and distribution to Haskell programs. This +project is an implementation of that distributed computing interface, where +processes communicate with one another through explicit message passing rather +than shared memory. + +Originally described by the joint [Towards Haskell in the Cloud][haskell11-ch] paper, +Cloud Haskell has be re-written from the ground up and supports a rich and +growing number of features for + +* building concurrent applications using asynchronous message passing +* building distributed computing applications +* building fault tolerant systems +* running Cloud Haskell nodes on various network transports +* working with several network transport implementations (and more in the pipeline) +* supporting *static* values (required for remote communication) + +There is a +[presentation][fun201202-coutts] +on Cloud Haskell and this reimplementation, which is worth reading in conjunction +with the documentation and wiki pages on this website.. + +Cloud Haskell comprises the following components, some of which are complete, +others experimental. There are three main parts: + +#### The core libraries + +* [distributed-process][distributed-process]: Base concurrency and distribution support. It provides a number of primitives known from Erlang like `link` and `monitor`. +* [distributed-static][distributed-static]: Support for static values +* [rank1dynamic][rank1dynamic]: Like `Data.Dynamic` and `Data.Typeable` but supporting polymorphic values + +#### The platform libraries + +* [distributed-process-client-server][distributed-process-client-server]: Common client/server patterns like Erlang's `gen_server` +* [distributed-process-async][distributed-process-async]: Future-style computations +* [distributed-process-task][distributed-process-task]: A worker queue +* [distributed-process-extras][distributed-process-extras]: Monitoring, logging, resolving names etc. +* [distributed-process-registry][distributed-process-registry]: A key-value registry +* [distributed-process-execution][distributed-process-execution]: Load regulation, work shedding, hand-off etc. + +#### The network layer + +* [network-transport][network-transport]: Generic `Network.Transport` API +* [network-transport-tcp][network-transport-tcp]: TCP realisation of `Network.Transport` +* [network-transport-inmemory][network-transport-inmemory]: In-memory realisation of `Network.Transport` (incomplete) +* [network-transport-composed][network-transport-composed]: Compose two transports (very preliminary) +* [distributed-process-simplelocalnet][distributed-process-simplelocalnet]: Simple backend for local networks +* [distributed-process-azure][distributed-process-azure]: Azure backend for Cloud Haskell (proof of concept) + +One of Cloud Haskell's goals is to separate the transport layer from the +*process layer*, so that the transport backend is entirely independent. In fact +other projects can and do reuse the transport layer, even if they don't use or +have their own process layer (see e.g. [HdpH][hdph]). + +Abstracting over the transport layer allows different protocols for +message passing, including TCP/IP, UDP, +[MPI](http://en.wikipedia.org/wiki/Message_Passing_Interface), +[CCI](http://www.olcf.ornl.gov/center-projects/common-communication-interface/), +[ZeroMQ](http://zeromq.org), [SSH](http://openssh.com), MVars, Unix pipes, and more. Each of these transports provides +its own implementation of the `Network.Transport` API and provide a means of creating +new connections for use within `Control.Distributed.Process`. + +The following diagram shows dependencies between the various subsystems, +in an application using Cloud Haskell, where arrows represent explicit +directional dependencies. + +----- + + +------------------------------------------------------------+ + | Application | + +------------------------------------------------------------+ + | | + V V + +-------------------------+ +------------------------------+ + | Cloud Haskell |<--| Cloud Haskell Backend | + | (distributed-process) | | (distributed-process-...) | + +-------------------------+ +------------------------------+ + | ______/ | + V V V + +-------------------------+ +------------------------------+ + | Transport Interface |<--| Transport Implementation | + | (network-transport) | | (network-transport-...) | + +-------------------------+ +------------------------------+ + | + V + +------------------------------+ + | Haskell/C Transport Library | + +------------------------------+ + +----- + +In this diagram, the various nodes roughly correspond to specific modules: + + Cloud Haskell : Control.Distributed.Process + Cloud Haskell : Control.Distributed.Process.* + Transport Interface : Network.Transport + Transport Implementation : Network.Transport.* + +An application is built using the primitives provided by the Cloud +Haskell layer, provided by the `Control.Distributed.Process` module, which +defines abstractions such as nodes and processes. + +The application also depends on a Cloud Haskell Backend, which +provides functions to allow the initialisation of the transport layer +using whatever topology might be appropriate to the application. + +It is, of course, possible to create new Cloud Haskell nodes by +using a Network Transport Backend such as `Network.Transport.TCP` +directly. + +The Cloud Haskell interface and backend make use of the Transport +interface provided by the `Network.Transport` module. +This also serves as an interface for the `Network.Transport.*` +module, which provides a specific implementation for this transport, +and may, for example, be based on some external library written in +Haskell or C. + +### Network Transport Abstraction Layer + +Cloud Haskell's generic [network-transport][network-transport] API is entirely independent of +the concurrency and messaging passing capabilities of the *process layer*. +Cloud Haskell applications are built using the primitives provided by the +*process layer* (i.e., [distributed-process][distributed-process]), which provides abstractions +such as nodes and processes. Applications must also depend on a Cloud Haskell +backend, which provides functions to allow the initialisation of the transport +layer using whatever topology might be appropriate to the application. + +`Network.Transport` is a network abstraction layer geared towards specific +classes of applications, offering the following high level concepts: + +* Nodes in the network are represented by `EndPoint`s. These are heavyweight stateful objects. +* Each `EndPoint` has an `EndPointAddress`. +* Connections can be established from one `EndPoint` to another using the `EndPointAddress` of the remote end. +* The `EndPointAddress` can be serialised and sent over the network, whereas `EndPoint`s and connections cannot. +* Connections between `EndPoint`s are unidirectional and lightweight. +* Outgoing messages are sent via a `Connection` object that represents the sending end of the connection. +* Incoming messages for **all** of the incoming connections on an `EndPoint` are collected via a shared receive queue. +* In addition to incoming messages, `EndPoint`s are notified of other `Event`s such as new connections or broken connections. + +This design was heavily influenced by the design of the Common Communication Interface ([CCI](http://www.olcf.ornl.gov/center-projects/common-communication-interface/)). Important design goals are: + +* Connections should be lightweight: it should be no problem to create thousands of connections between endpoints. +* Error handling is explicit: every function declares as part of its type which errors it can return (no exceptions are thrown) +* Error handling is "abstract": errors that originate from implementation specific problems (such as "no more sockets" in the TCP implementation) get mapped to generic errors ("insufficient resources") at the Transport level. + +For the purposes of most Cloud Haskell applications, it is sufficient to know +enough about the `Network.Transport` API to instantiate a backend with the +required configuration and pass the returned opaque handle to the `Node` API +in order to establish a new, connected, running node. More involved setups are, +of course, possible; The simplest use of the API is thus + +{% highlight haskell %} +main :: IO +main = do + Right transport <- createTransport "127.0.0.1" "10080" defaultTCPParameters + node1 <- newLocalNode transport initRemoteTable +{% endhighlight %} + +Here we can see that the application depends explicitly on the +`defaultTCPParameters` and `createTransport` functions from +`Network.Transport.TCP`, but little else. The application *can* make use +of other `Network.Transport` APIs if required, but for the most part this +is irrelevant and the application will interact with Cloud Haskell through +the *Process Layer* and *Platform*. + +For more details about `Network.Transport` please see the [wiki page](/wiki/networktransport.html). + +### Concurrency and Distribution + +The *Process Layer* is where Cloud Haskell's support for concurrency and +distributed programming are exposed to application developers. This layer +deals explicitly with + +The core of Cloud Haskell's concurrency and distribution support resides in the +[distributed-process][distributed-process] library. As well as the APIs necessary for starting +nodes and forking processes on them, we find all the basic primitives required +to + +* spawn processes locally and remotely +* send and receive messages, optionally using typed channels +* monitor and/or link to processes, channels and other nodes + +Most of this is easy enough to follow in the haddock documentation and the +various tutorials. Here we focus on the essential *concepts* behind the +process layer. + +A concurrent process is somewhat like a Haskell thread - in fact it is a +`forkIO` thread - but one that can send and receive messages through its +*process mailbox*. Each process can send messages asynchronously to other +processes, and can receive messages synchronously from its own mailbox. +The conceptual difference between threads and processes is that the latter +do not share state, but communicate only via message passing. + +Code that is executed in this manner must run in the `Process` monad. Our +process will look like any other monad code, plus we provide and instance +of `MonadIO` for `Process`, so you can `liftIO` to make IO actions +available. + +Processes reside on nodes, which in our implementation map directly to the +`Control.Distributed.Processes.Node` module. Given a configured +`Network.Transport` backend, starting a new node is fairly simple: + +{% highlight haskell %} +newLocalNode :: Transport -> IO LocalNode +{% endhighlight %} + +Once this function returns, the node will be *up and running* and able to +interact with other nodes and host processes. It is possible to start more +than one node in the same running program, though if you do this they will +continue to send messages to one another using the supplied `Network.Transport` +backend. + +Given a new node, there are two primitives for starting a new process. + +{% highlight haskell %} +forkProcess :: LocalNode -> Process () -> IO ProcessId +runProcess :: LocalNode -> Process () -> IO () +{% endhighlight %} + +Once we've spawned some processes, they can communicate with one another +using the messaging primitives provided by [distributed-process][distributed-process], +which are well documented in the haddocks. + +### What is Serializable + +Processes can send data if the type implements the `Serializable` typeclass, +which is done indirectly by implementing `Binary` and deriving `Typeable`. +Implementations are already provided for primitives and some commonly used +data structures. As programmers, we see the messages in nice high-level form +(e.g., `Int`, `String`, `Ping`, `Pong`, etc), however these data have to be +encoded in order to be sent over a communications channel. + +Not all types are `Serializable`, for example concurrency primitives such as +`MVar` and `TVar` are meaningless outside the context of threads with a shared +memory. Cloud Haskell programs remain free to use these constructs within +processes or within processes on the same machine though. If you want to +pass data between processes using *ordinary* concurrency primitives such as +`STM` then you're free to do so. Processes spawned locally can share +types such as `TMVar` just as normal Haskell threads would. + +### Typed Channels + +Channels provides an alternative to message transmission with `send` and `expect`. +While `send` and `expect` allow us to transmit messages of any `Serializable` +type, channels require a uniform type. Channels work like a distributed equivalent +of Haskell's `Control.Concurrent.Chan`, however they have distinct ends: a single +receiving port and a corollary send port. + +Channels provide a nice alternative to *bare send and receive*, which is a bit +*un-Haskell-ish*, since our process' message queue can contain messages of multiple +types, forcing us to undertake dynamic type checking at runtime. + +We create channels with a call to `newChan`, and send/receive on them using the +`{send,receive}Chan` primitives: + +{% highlight haskell %} +channelsDemo :: Process () +channelsDemo = do + (sp, rp) <- newChan :: Process (SendPort String, ReceivePort String) + + -- send on a channel + spawnLocal $ sendChan sp "hello!" + + -- receive on a channel + m <- receiveChan rp + say $ show m +{% endhighlight %} + +Channels are particularly useful when you are sending a message that needs a +response, because we know exactly where to look for the reply. + +Channels can also allow message types to be simplified, as passing a +`ProcessId` for the reply isn't required. Channels aren't so useful when we +need to spawn a process and send a bunch a messages to it, then wait for +replies however; we can’t send a `ReceivePort` since it is not `Serializable`. + +`ReceivePort`s can be merged, so we can listen on several simultaneously. In the +latest version of [distributed-process][distributed-process], we can listen for *regular* messages +and multiple channels at the same time, using `matchChan` in the list of +allowed matches passed `receiveWait` and `receiveTimeout`. + +### Linking and monitoring + +Processes can be linked to other processes, nodes or channels. Links are unidirectional, +and guarantee that once the linked object *dies*, the linked process will also be +terminated. Monitors do not cause the *listening* process to exit, but rather they +put a `ProcessMonitorNotification` into the process' mailbox. Linking and monitoring +are foundational tools for *supervising* processes, where a top level process manages +a set of children, starting, stopping and restarting them as necessary. + +### Stopping Processes + +Because processes are implemented with `forkIO` we might be tempted to stop +them by throwing an asynchronous exception to the process, but this is almost +certainly the wrong thing to do. Firstly, processes might reside on a remote +node, in which case throwing an exception is impossible. Secondly, if we send +some messages to a process' mailbox and then dispatch an exception to kill it, +there is no guarantee that the subject will receive our message before being +terminated by the asynchronous exception. + +To terminate a process unconditionally, we use the `kill` primitive, which +dispatches an asynchronous exception (killing the subject) safely, respecting +remote calls to processes on disparate nodes and observing message ordering +guarantees such that `send pid "hello" >> kill pid "goodbye"` behaves quite +unsurprisingly, delivering the message before the kill signal. + +Exit signals come in two flavours however - those that can be caught and those +that cannot. Whilst a call to `kill` results in an _un-trappable_ exception, +a call to `exit :: (Serializable a) => ProcessId -> a -> Process ()` will dispatch +an exit signal to the specified process that can be caught. These *signals* are +intercepted and handled by the destination process using `catchExit`, allowing +the receiver to match on the `Serializable` datum tucked away in the *exit signal* +and decide whether to oblige or not. + +---- + +### Rethinking the Task Layer + +[Towards Haskell in the Cloud][haskell11-ch] describes a multi-layered architecture, in +which manipulation of concurrent processes and message passing between them +is managed in the *process layer*, whilst a higher level API described as the +*task layer* provides additional features such as + +* automatic recovery from failures +* data centric processing model +* a promise (or *future*) abstraction, representing the result of a calculation that may or may not have yet completed + +The [distributed-process-task][distributed-process-task] library implements parts of the +*task layer*, but takes a very different approach to that described +in the original paper and implemented by the [remote][remote] package. In particular, +we diverge from the original design and defer to many of the principles +defined by Erlang's [Open Telecom Platform][OTP], taking in some well established +Haskell concurrency design patterns along the way. + +In fact, [distributed-process-async][distributed-process-async] does not really consider the +*task layer* in great detail. We provide an API comparable to remote's +`Promise` in `Control.Distributed.Process.Async`. This API however, +is derived from Simon Marlow's [Control.Concurrent.Async][async] package, and is not +limited to blocking queries on `Async` handles in the same way. Instead our +[API][d-p-async-async] handles both blocking and non-blocking queries, polling +and working with lists of `Async` handles. We also eschew throwing exceptions +to indicate asynchronous task failures, instead handling *task* and connectivity +failures using monitors. Users of the API need only concern themselves with the +`AsyncResult`, which encodes the status and (possibly) outcome of the computation +simply. + +------ + +{% highlight haskell %} +demoAsync :: Process () +demoAsync = do + -- spawning a new task is fairly easy - this one is linked + -- so if the caller dies, the task is killed too + hAsync :: Async String + hAsync <- asyncLinked $ (expect >>= return) :: Process String + + -- there is a rich API of functions to query an async handle + AsyncPending <- poll hAsync -- not finished yet + + -- we can cancel the task if we want to + -- cancel hAsync + + -- or cancel it and wait until it has exited + -- cancelWait hAsync + + -- we can wait on the task and timeout if it's still busy + Nothing <- waitTimeout (within 3 Seconds) hAsync + + -- or finally, we can block until the task is finished! + asyncResult <- wait hAsync + case asyncResult of + (AsyncDone res) -> say (show res) -- a finished task/result + AsyncCancelled -> say "it was cancelled!?" + AsyncFailed (DiedException r) -> say $ "it failed: " ++ (show r) +{% endhighlight %} + +------ + +Unlike remote's task layer, we do not exclude IO, allowing tasks to run in +the `Process` monad and execute arbitrary code. Providing a monadic wrapper +around `Async` that disallows side effects is relatively simple, and we +do not consider the presence of side effects a barrier to fault tolerance +and automated process restarts. Erlang does not forbid *IO* in its processes, +and yet that doesn't render supervision trees ineffective. They key is to +provide a rich enough API that stateful processes can recognise whether or +not they need to provide idempotent initialisation routines. + +The utility of preventing side effects using the type system is, however, not +to be sniffed at. A substrate of the `ManagedProcess` API is under development +that provides a *safe process* abstraction in which side effect free computations +can be embedded, whilst reaping the benefits of the framework. + +Work is also underway to provide abstractions for managing asynchronous tasks +at a higher level, focussing on workload distribution and load regulation. + +The kinds of task that can be performed by the async implementations in +[distributed-process-async][distributed-process-async] are limited only by their return type: +it **must** be `Serializable` - that much should've been obvious by now. +The type of asynchronous task definitions comes in two flavours, one for +local nodes which require no remote-table or static serialisation dictionary, +and another for tasks you wish to execute on remote nodes. + +{% highlight haskell %} +-- | A task to be performed asynchronously. +data AsyncTask a = + AsyncTask + { + asyncTask :: Process a -- ^ the task to be performed + } + | AsyncRemoteTask + { + asyncTaskDict :: Static (SerializableDict a) + -- ^ the serializable dict required to spawn a remote process + , asyncTaskNode :: NodeId + -- ^ the node on which to spawn the asynchronous task + , asyncTaskProc :: Closure (Process a) + -- ^ the task to be performed, wrapped in a closure environment + } +{% endhighlight %} + +The API for `Async` is fairly rich, so reading the haddocks is suggested. + +#### Managed Processes + +The main idea behind a `ManagedProcess` is to separate the functional +and non-functional aspects of an actor. By functional, we mean whatever +application specific task the actor performs, and by non-functional +we mean the *concurrency* or, more precisely, handling of the process' +mailbox and its interaction with other actors (i.e., clients). + +Looking at *typed channels*, we noted that their insistence on a specific input +domain was more *haskell-ish* than working with bare send and receive primitives. +The `Async` sub-package also provides a type safe interface for receiving data, +although it is limited to running a computation and waiting for its result. + +The [Control.Distributed.Processes.Platform.ManagedProcess][d-p-client-server-ManagedProcess] API provides a +number of different abstractions that can be used to achieve similar benefits +in your code. It works by introducing a standard protocol between your process +and the *world outside*, which governs how to handle request/reply processing, +exit signals, timeouts, sleeping/hibernation with `threadDelay` and even provides +hooks that terminating processes can use to clean up residual state. + +The [API documentation][d-p-client-server-ManagedProcess] is quite extensive, so here we will simply point +out the obvious differences. A process implemented with `ManagedProcess` +can present a type safe API to its callers (and the server side code too!), +although that's not its primary benefit. For a very simplified example: + +{% highlight haskell %} +add :: ProcessId -> Double -> Double -> Process Double +add sid x y = call sid (Add x y) + +divide :: ProcessId -> Double -> Double + -> Process (Either DivByZero Double) +divide sid x y = call sid (Divide x y ) + +launchMathServer :: Process ProcessId +launchMathServer = + let server = statelessProcess { + apiHandlers = [ + handleCall_ (\(Add x y) -> return (x + y)) + , handleCallIf_ (input (\(Divide _ y) -> y /= 0)) handleDivide + , handleCall_ (\(Divide _ _) -> divByZero) + ] + } + in spawnLocal $ start () (statelessInit Infinity) server >> return () + where handleDivide :: Divide -> Process (Either DivByZero Double) + handleDivide (Divide x y) = return $ Right $ x / y + + divByZero :: Process (Either DivByZero Double) + divByZero = return $ Left DivByZero +{% endhighlight %} + +Apart from the types and the imports, that is a complete definition. Whilst +it's not so obvious what's going on here, the key point is that the invocation +of `call` in the client facing API functions handles **all** of the relevant +waiting/blocking, converting the async result and so on. Note that the +*managed process* does not interact with its mailbox at all, but rather +just provides callback functions which take some state and either return a +new state and a reply, or just a new state. The process is *managed* in the +sense that its mailbox is under someone else's control. + +A NOTE ABOUT THE CALL API AND THAT IT WILL FAIL (WITH UNHANDLED MESSAGE) IF +THE CALLER IS EXPECTING A TYPE THAT DIFFERS FROM THE ONE THE SERVER PLANS +TO RETURN, SINCE THE RETURN TYPE IS ENCODED IN THE CALL-MESSAGE TYPE ITSELF. + +TODO: WRITE A TEST TO PROVE THE ABOVE + +TODO: ADD AN API BASED ON SESSION TYPES AS A KIND OF MANAGED PROCESS..... + +In a forthcoming tutorial, we'll look at the `Control.Distributed.Process.Platform.Task` +API, which looks a lot like `Async` but manages exit signals in a single thread and makes +configurable task pools and task supervision strategy part of its API. + +More complex examples of the `ManagedProcess` API can be seen in the +[Managed Processes tutorial](tutorials/4ch.html). API documentation for HEAD is available +[here][d-p-client-server-ManagedProcess]. + +### Supervision Trees + +TBC + +### Process Groups + +TBC + +[cloud-haskell]: http://haskell-distributed.github.io/documentation.html +[fun201202-coutts]: http://sneezy.cs.nott.ac.uk/fun/2012-02/coutts-2012-02-28.pdf +[distributed-process]: https://github.com/haskell-distributed/distributed-process +[distributed-process-client-server]: https://github.com/haskell-distributed/distributed-process-client-server +[distributed-process-async]: https://github.com/haskell-distributed/distributed-process-async +[distributed-process-execution]: https://github.com/haskell-distributed/distributed-process-execution +[distributed-process-extras]: https://github.com/haskell-distributed/distributed-process-extras +[distributed-process-task]: https://github.com/haskell-distributed/distributed-process-task +[distributed-process-registry]: https://github.com/haskell-distributed/distributed-process-registry +[distributed-static]: http://hackage.haskell.org/package/distributed-static +[rank1dynamic]: http://hackage.haskell.org/package/rank1dynamic +[network-transport]: http://hackage.haskell.org/package/network-transport +[network-transport-tcp]: http://hackage.haskell.org/package/network-transport-tcp +[network-transport-inmemory]: https://github.com/haskell-distributed/network-transport-inmemory +[network-transport-composed]: https://github.com/haskell-distributed/network-transport-composed +[distributed-process-simplelocalnet]: http://hackage.haskell.org/package/distributed-process-simplelocalnet +[distributed-process-azure]: http://hackage.haskell.org/package/distributed-process-azure +[hdph]: http://hackage.haskell.org/package/hdph +[haskell11-ch]: http://research.microsoft.com/en-us/um/people/simonpj/papers/parallel/remote.pdf +[OTP]: http://en.wikipedia.org/wiki/Open_Telecom_Platform +[remote]: http://hackage.haskell.org/package/remote +[d-p-async-async]: https://hackage.haskell.org/package/distributed-process-async/docs/Control-Distributed-Process-Async.html +[async]: http://hackage.haskell.org/package/async +[d-p-client-server-ManagedProcess]: https://hackage.haskell.org/package/distributed-process-client-server/docs/Control-Distributed-Process-ManagedProcess.html diff --git a/website/ico/favicon.ico b/website/ico/favicon.ico new file mode 100644 index 00000000..047f574b Binary files /dev/null and b/website/ico/favicon.ico differ diff --git a/website/img/NetworkTCP.png b/website/img/NetworkTCP.png new file mode 100644 index 00000000..48926b47 Binary files /dev/null and b/website/img/NetworkTCP.png differ diff --git a/website/img/NetworkTCP.svg b/website/img/NetworkTCP.svg new file mode 100644 index 00000000..da33d2fb --- /dev/null +++ b/website/img/NetworkTCP.svg @@ -0,0 +1,657 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + image/svg+xml + + + + + + + + + + + + 198.51.100.1:1080 + 198.51.100.1:1081 + + 198.51.100.2:1080 + + 198.51.100.1:1080:0 + + 198.51.100.1:1081:0 + + 198.51.100.2:1080:0 + + 198.51.100.2:1080:1 + + + + + + + + + + + + + + + + + + + Endpoint + Transport + TCP connection(bi-directional) + + Transport connection(uni-directional) + Chan + + diff --git a/website/img/OTP-Diagrams.png b/website/img/OTP-Diagrams.png new file mode 100644 index 00000000..a103f92f Binary files /dev/null and b/website/img/OTP-Diagrams.png differ diff --git a/website/img/alert.png b/website/img/alert.png new file mode 100644 index 00000000..fe1f4570 Binary files /dev/null and b/website/img/alert.png differ diff --git a/website/img/back1.jpg b/website/img/back1.jpg new file mode 100644 index 00000000..ba88d759 Binary files /dev/null and b/website/img/back1.jpg differ diff --git a/website/img/back2.jpg b/website/img/back2.jpg new file mode 100755 index 00000000..d68f5b0c Binary files /dev/null and b/website/img/back2.jpg differ diff --git a/website/img/back3.jpg b/website/img/back3.jpg new file mode 100644 index 00000000..a7a3e61b Binary files /dev/null and b/website/img/back3.jpg differ diff --git a/website/img/email_128x128.png b/website/img/email_128x128.png new file mode 100644 index 00000000..67b61dec Binary files /dev/null and b/website/img/email_128x128.png differ diff --git a/website/img/feed-icon-14x14.png b/website/img/feed-icon-14x14.png new file mode 100755 index 00000000..b3c949d2 Binary files /dev/null and b/website/img/feed-icon-14x14.png differ diff --git a/website/img/feed-icon-28x28.png b/website/img/feed-icon-28x28.png new file mode 100755 index 00000000..d64c669c Binary files /dev/null and b/website/img/feed-icon-28x28.png differ diff --git a/website/img/github_logo_300x300.png b/website/img/github_logo_300x300.png new file mode 100644 index 00000000..e38b7638 Binary files /dev/null and b/website/img/github_logo_300x300.png differ diff --git a/website/img/glyphicons-halflings-white.png b/website/img/glyphicons-halflings-white.png new file mode 100644 index 00000000..3bf6484a Binary files /dev/null and b/website/img/glyphicons-halflings-white.png differ diff --git a/website/img/glyphicons-halflings.png b/website/img/glyphicons-halflings.png new file mode 100644 index 00000000..a9969993 Binary files /dev/null and b/website/img/glyphicons-halflings.png differ diff --git a/website/img/icon_irc.png b/website/img/icon_irc.png new file mode 100644 index 00000000..850d3f33 Binary files /dev/null and b/website/img/icon_irc.png differ diff --git a/website/img/info.png b/website/img/info.png new file mode 100644 index 00000000..4e197d43 Binary files /dev/null and b/website/img/info.png differ diff --git a/website/img/irc_icon.png b/website/img/irc_icon.png new file mode 100644 index 00000000..38ac9655 Binary files /dev/null and b/website/img/irc_icon.png differ diff --git a/website/img/logoBambooPNG.png b/website/img/logoBambooPNG.png new file mode 100644 index 00000000..b8a116e1 Binary files /dev/null and b/website/img/logoBambooPNG.png differ diff --git a/website/img/one-for-all-left-to-right.png b/website/img/one-for-all-left-to-right.png new file mode 100644 index 00000000..9d7c728c Binary files /dev/null and b/website/img/one-for-all-left-to-right.png differ diff --git a/website/img/one-for-all.png b/website/img/one-for-all.png new file mode 100644 index 00000000..1d2456da Binary files /dev/null and b/website/img/one-for-all.png differ diff --git a/website/img/one-for-one.png b/website/img/one-for-one.png new file mode 100644 index 00000000..991c8501 Binary files /dev/null and b/website/img/one-for-one.png differ diff --git a/website/img/sup1.png b/website/img/sup1.png new file mode 100644 index 00000000..71565e23 Binary files /dev/null and b/website/img/sup1.png differ diff --git a/website/index.md b/website/index.md new file mode 100644 index 00000000..f28e4179 --- /dev/null +++ b/website/index.md @@ -0,0 +1,33 @@ +--- +layout: site +title: Home +--- +Cloud Haskell: Erlang-style concurrent and distributed programming in Haskell. +The Cloud Haskell Platform consists of a +[generic network transport API](https://github.com/haskell-distributed/network-transport), +libraries for sending [static closures](https://github.com/haskell-distributed/distributed-static) to remote nodes, a rich [API for distributed programming](https://github.com/haskell-distributed/distributed-process) and a +set of platform libraries modelled after Erlang's [Open Telecom Platform](http://www.erlang.org/doc/). + +Generic network transport backends have been developed for +[TCP](https://github.com/haskell-distributed/network-transport-tcp) and +[in-memory](https://github.com/haskell-distributed/network-transport-inmemory) +messaging, and several other implementations are available including a transport for +[Windows Azure](https://github.com/haskell-distributed/distributed-process-azure). The [wiki](/wiki.html) provides links to a number of resources for learning about the conceptual underpinnings of Cloud Haskell, and some [examples](https://github.com/haskell-distributed/distributed-process-demos). + +Documentation is available on this site for HEAD, or +[hackage](http://hackage.haskell.org/package/distributed-process) for the current and preceding versions of +each library. + +### Recent Activity + +
+
+
    + {% for post in site.posts %} +
  • + {{ post.date | date: "%B %e, %Y" }} · {{post.author}} · {{ post.title }} +
    • + {% endfor %} +
+
+
diff --git a/website/js/bootstrap.js b/website/js/bootstrap.js new file mode 100644 index 00000000..6c15a583 --- /dev/null +++ b/website/js/bootstrap.js @@ -0,0 +1,2159 @@ +/* =================================================== + * bootstrap-transition.js v2.2.2 + * http://twitter.github.com/bootstrap/javascript.html#transitions + * =================================================== + * Copyright 2012 Twitter, Inc. + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + * ========================================================== */ + + +!function ($) { + + "use strict"; // jshint ;_; + + + /* CSS TRANSITION SUPPORT (http://www.modernizr.com/) + * ======================================================= */ + + $(function () { + + $.support.transition = (function () { + + var transitionEnd = (function () { + + var el = document.createElement('bootstrap') + , transEndEventNames = { + 'WebkitTransition' : 'webkitTransitionEnd' + , 'MozTransition' : 'transitionend' + , 'OTransition' : 'oTransitionEnd otransitionend' + , 'transition' : 'transitionend' + } + , name + + for (name in transEndEventNames){ + if (el.style[name] !== undefined) { + return transEndEventNames[name] + } + } + + }()) + + return transitionEnd && { + end: transitionEnd + } + + })() + + }) + +}(window.jQuery);/* ========================================================== + * bootstrap-alert.js v2.2.2 + * http://twitter.github.com/bootstrap/javascript.html#alerts + * ========================================================== + * Copyright 2012 Twitter, Inc. + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + * ========================================================== */ + + +!function ($) { + + "use strict"; // jshint ;_; + + + /* ALERT CLASS DEFINITION + * ====================== */ + + var dismiss = '[data-dismiss="alert"]' + , Alert = function (el) { + $(el).on('click', dismiss, this.close) + } + + Alert.prototype.close = function (e) { + var $this = $(this) + , selector = $this.attr('data-target') + , $parent + + if (!selector) { + selector = $this.attr('href') + selector = selector && selector.replace(/.*(?=#[^\s]*$)/, '') //strip for ie7 + } + + $parent = $(selector) + + e && e.preventDefault() + + $parent.length || ($parent = $this.hasClass('alert') ? $this : $this.parent()) + + $parent.trigger(e = $.Event('close')) + + if (e.isDefaultPrevented()) return + + $parent.removeClass('in') + + function removeElement() { + $parent + .trigger('closed') + .remove() + } + + $.support.transition && $parent.hasClass('fade') ? + $parent.on($.support.transition.end, removeElement) : + removeElement() + } + + + /* ALERT PLUGIN DEFINITION + * ======================= */ + + var old = $.fn.alert + + $.fn.alert = function (option) { + return this.each(function () { + var $this = $(this) + , data = $this.data('alert') + if (!data) $this.data('alert', (data = new Alert(this))) + if (typeof option == 'string') data[option].call($this) + }) + } + + $.fn.alert.Constructor = Alert + + + /* ALERT NO CONFLICT + * ================= */ + + $.fn.alert.noConflict = function () { + $.fn.alert = old + return this + } + + + /* ALERT DATA-API + * ============== */ + + $(document).on('click.alert.data-api', dismiss, Alert.prototype.close) + +}(window.jQuery);/* ============================================================ + * bootstrap-button.js v2.2.2 + * http://twitter.github.com/bootstrap/javascript.html#buttons + * ============================================================ + * Copyright 2012 Twitter, Inc. + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + * ============================================================ */ + + +!function ($) { + + "use strict"; // jshint ;_; + + + /* BUTTON PUBLIC CLASS DEFINITION + * ============================== */ + + var Button = function (element, options) { + this.$element = $(element) + this.options = $.extend({}, $.fn.button.defaults, options) + } + + Button.prototype.setState = function (state) { + var d = 'disabled' + , $el = this.$element + , data = $el.data() + , val = $el.is('input') ? 'val' : 'html' + + state = state + 'Text' + data.resetText || $el.data('resetText', $el[val]()) + + $el[val](data[state] || this.options[state]) + + // push to event loop to allow forms to submit + setTimeout(function () { + state == 'loadingText' ? + $el.addClass(d).attr(d, d) : + $el.removeClass(d).removeAttr(d) + }, 0) + } + + Button.prototype.toggle = function () { + var $parent = this.$element.closest('[data-toggle="buttons-radio"]') + + $parent && $parent + .find('.active') + .removeClass('active') + + this.$element.toggleClass('active') + } + + + /* BUTTON PLUGIN DEFINITION + * ======================== */ + + var old = $.fn.button + + $.fn.button = function (option) { + return this.each(function () { + var $this = $(this) + , data = $this.data('button') + , options = typeof option == 'object' && option + if (!data) $this.data('button', (data = new Button(this, options))) + if (option == 'toggle') data.toggle() + else if (option) data.setState(option) + }) + } + + $.fn.button.defaults = { + loadingText: 'loading...' + } + + $.fn.button.Constructor = Button + + + /* BUTTON NO CONFLICT + * ================== */ + + $.fn.button.noConflict = function () { + $.fn.button = old + return this + } + + + /* BUTTON DATA-API + * =============== */ + + $(document).on('click.button.data-api', '[data-toggle^=button]', function (e) { + var $btn = $(e.target) + if (!$btn.hasClass('btn')) $btn = $btn.closest('.btn') + $btn.button('toggle') + }) + +}(window.jQuery);/* ========================================================== + * bootstrap-carousel.js v2.2.2 + * http://twitter.github.com/bootstrap/javascript.html#carousel + * ========================================================== + * Copyright 2012 Twitter, Inc. + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + * ========================================================== */ + + +!function ($) { + + "use strict"; // jshint ;_; + + + /* CAROUSEL CLASS DEFINITION + * ========================= */ + + var Carousel = function (element, options) { + this.$element = $(element) + this.options = options + this.options.pause == 'hover' && this.$element + .on('mouseenter', $.proxy(this.pause, this)) + .on('mouseleave', $.proxy(this.cycle, this)) + } + + Carousel.prototype = { + + cycle: function (e) { + if (!e) this.paused = false + this.options.interval + && !this.paused + && (this.interval = setInterval($.proxy(this.next, this), this.options.interval)) + return this + } + + , to: function (pos) { + var $active = this.$element.find('.item.active') + , children = $active.parent().children() + , activePos = children.index($active) + , that = this + + if (pos > (children.length - 1) || pos < 0) return + + if (this.sliding) { + return this.$element.one('slid', function () { + that.to(pos) + }) + } + + if (activePos == pos) { + return this.pause().cycle() + } + + return this.slide(pos > activePos ? 'next' : 'prev', $(children[pos])) + } + + , pause: function (e) { + if (!e) this.paused = true + if (this.$element.find('.next, .prev').length && $.support.transition.end) { + this.$element.trigger($.support.transition.end) + this.cycle() + } + clearInterval(this.interval) + this.interval = null + return this + } + + , next: function () { + if (this.sliding) return + return this.slide('next') + } + + , prev: function () { + if (this.sliding) return + return this.slide('prev') + } + + , slide: function (type, next) { + var $active = this.$element.find('.item.active') + , $next = next || $active[type]() + , isCycling = this.interval + , direction = type == 'next' ? 'left' : 'right' + , fallback = type == 'next' ? 'first' : 'last' + , that = this + , e + + this.sliding = true + + isCycling && this.pause() + + $next = $next.length ? $next : this.$element.find('.item')[fallback]() + + e = $.Event('slide', { + relatedTarget: $next[0] + }) + + if ($next.hasClass('active')) return + + if ($.support.transition && this.$element.hasClass('slide')) { + this.$element.trigger(e) + if (e.isDefaultPrevented()) return + $next.addClass(type) + $next[0].offsetWidth // force reflow + $active.addClass(direction) + $next.addClass(direction) + this.$element.one($.support.transition.end, function () { + $next.removeClass([type, direction].join(' ')).addClass('active') + $active.removeClass(['active', direction].join(' ')) + that.sliding = false + setTimeout(function () { that.$element.trigger('slid') }, 0) + }) + } else { + this.$element.trigger(e) + if (e.isDefaultPrevented()) return + $active.removeClass('active') + $next.addClass('active') + this.sliding = false + this.$element.trigger('slid') + } + + isCycling && this.cycle() + + return this + } + + } + + + /* CAROUSEL PLUGIN DEFINITION + * ========================== */ + + var old = $.fn.carousel + + $.fn.carousel = function (option) { + return this.each(function () { + var $this = $(this) + , data = $this.data('carousel') + , options = $.extend({}, $.fn.carousel.defaults, typeof option == 'object' && option) + , action = typeof option == 'string' ? option : options.slide + if (!data) $this.data('carousel', (data = new Carousel(this, options))) + if (typeof option == 'number') data.to(option) + else if (action) data[action]() + else if (options.interval) data.cycle() + }) + } + + $.fn.carousel.defaults = { + interval: 5000 + , pause: 'hover' + } + + $.fn.carousel.Constructor = Carousel + + + /* CAROUSEL NO CONFLICT + * ==================== */ + + $.fn.carousel.noConflict = function () { + $.fn.carousel = old + return this + } + + /* CAROUSEL DATA-API + * ================= */ + + $(document).on('click.carousel.data-api', '[data-slide]', function (e) { + var $this = $(this), href + , $target = $($this.attr('data-target') || (href = $this.attr('href')) && href.replace(/.*(?=#[^\s]+$)/, '')) //strip for ie7 + , options = $.extend({}, $target.data(), $this.data()) + $target.carousel(options) + e.preventDefault() + }) + +}(window.jQuery);/* ============================================================= + * bootstrap-collapse.js v2.2.2 + * http://twitter.github.com/bootstrap/javascript.html#collapse + * ============================================================= + * Copyright 2012 Twitter, Inc. + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + * ============================================================ */ + + +!function ($) { + + "use strict"; // jshint ;_; + + + /* COLLAPSE PUBLIC CLASS DEFINITION + * ================================ */ + + var Collapse = function (element, options) { + this.$element = $(element) + this.options = $.extend({}, $.fn.collapse.defaults, options) + + if (this.options.parent) { + this.$parent = $(this.options.parent) + } + + this.options.toggle && this.toggle() + } + + Collapse.prototype = { + + constructor: Collapse + + , dimension: function () { + var hasWidth = this.$element.hasClass('width') + return hasWidth ? 'width' : 'height' + } + + , show: function () { + var dimension + , scroll + , actives + , hasData + + if (this.transitioning) return + + dimension = this.dimension() + scroll = $.camelCase(['scroll', dimension].join('-')) + actives = this.$parent && this.$parent.find('> .accordion-group > .in') + + if (actives && actives.length) { + hasData = actives.data('collapse') + if (hasData && hasData.transitioning) return + actives.collapse('hide') + hasData || actives.data('collapse', null) + } + + this.$element[dimension](0) + this.transition('addClass', $.Event('show'), 'shown') + $.support.transition && this.$element[dimension](this.$element[0][scroll]) + } + + , hide: function () { + var dimension + if (this.transitioning) return + dimension = this.dimension() + this.reset(this.$element[dimension]()) + this.transition('removeClass', $.Event('hide'), 'hidden') + this.$element[dimension](0) + } + + , reset: function (size) { + var dimension = this.dimension() + + this.$element + .removeClass('collapse') + [dimension](size || 'auto') + [0].offsetWidth + + this.$element[size !== null ? 'addClass' : 'removeClass']('collapse') + + return this + } + + , transition: function (method, startEvent, completeEvent) { + var that = this + , complete = function () { + if (startEvent.type == 'show') that.reset() + that.transitioning = 0 + that.$element.trigger(completeEvent) + } + + this.$element.trigger(startEvent) + + if (startEvent.isDefaultPrevented()) return + + this.transitioning = 1 + + this.$element[method]('in') + + $.support.transition && this.$element.hasClass('collapse') ? + this.$element.one($.support.transition.end, complete) : + complete() + } + + , toggle: function () { + this[this.$element.hasClass('in') ? 'hide' : 'show']() + } + + } + + + /* COLLAPSE PLUGIN DEFINITION + * ========================== */ + + var old = $.fn.collapse + + $.fn.collapse = function (option) { + return this.each(function () { + var $this = $(this) + , data = $this.data('collapse') + , options = typeof option == 'object' && option + if (!data) $this.data('collapse', (data = new Collapse(this, options))) + if (typeof option == 'string') data[option]() + }) + } + + $.fn.collapse.defaults = { + toggle: true + } + + $.fn.collapse.Constructor = Collapse + + + /* COLLAPSE NO CONFLICT + * ==================== */ + + $.fn.collapse.noConflict = function () { + $.fn.collapse = old + return this + } + + + /* COLLAPSE DATA-API + * ================= */ + + $(document).on('click.collapse.data-api', '[data-toggle=collapse]', function (e) { + var $this = $(this), href + , target = $this.attr('data-target') + || e.preventDefault() + || (href = $this.attr('href')) && href.replace(/.*(?=#[^\s]+$)/, '') //strip for ie7 + , option = $(target).data('collapse') ? 'toggle' : $this.data() + $this[$(target).hasClass('in') ? 'addClass' : 'removeClass']('collapsed') + $(target).collapse(option) + }) + +}(window.jQuery);/* ============================================================ + * bootstrap-dropdown.js v2.2.2 + * http://twitter.github.com/bootstrap/javascript.html#dropdowns + * ============================================================ + * Copyright 2012 Twitter, Inc. + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + * ============================================================ */ + + +!function ($) { + + "use strict"; // jshint ;_; + + + /* DROPDOWN CLASS DEFINITION + * ========================= */ + + var toggle = '[data-toggle=dropdown]' + , Dropdown = function (element) { + var $el = $(element).on('click.dropdown.data-api', this.toggle) + $('html').on('click.dropdown.data-api', function () { + $el.parent().removeClass('open') + }) + } + + Dropdown.prototype = { + + constructor: Dropdown + + , toggle: function (e) { + var $this = $(this) + , $parent + , isActive + + if ($this.is('.disabled, :disabled')) return + + $parent = getParent($this) + + isActive = $parent.hasClass('open') + + clearMenus() + + if (!isActive) { + $parent.toggleClass('open') + } + + $this.focus() + + return false + } + + , keydown: function (e) { + var $this + , $items + , $active + , $parent + , isActive + , index + + if (!/(38|40|27)/.test(e.keyCode)) return + + $this = $(this) + + e.preventDefault() + e.stopPropagation() + + if ($this.is('.disabled, :disabled')) return + + $parent = getParent($this) + + isActive = $parent.hasClass('open') + + if (!isActive || (isActive && e.keyCode == 27)) return $this.click() + + $items = $('[role=menu] li:not(.divider):visible a', $parent) + + if (!$items.length) return + + index = $items.index($items.filter(':focus')) + + if (e.keyCode == 38 && index > 0) index-- // up + if (e.keyCode == 40 && index < $items.length - 1) index++ // down + if (!~index) index = 0 + + $items + .eq(index) + .focus() + } + + } + + function clearMenus() { + $(toggle).each(function () { + getParent($(this)).removeClass('open') + }) + } + + function getParent($this) { + var selector = $this.attr('data-target') + , $parent + + if (!selector) { + selector = $this.attr('href') + selector = selector && /#/.test(selector) && selector.replace(/.*(?=#[^\s]*$)/, '') //strip for ie7 + } + + $parent = $(selector) + $parent.length || ($parent = $this.parent()) + + return $parent + } + + + /* DROPDOWN PLUGIN DEFINITION + * ========================== */ + + var old = $.fn.dropdown + + $.fn.dropdown = function (option) { + return this.each(function () { + var $this = $(this) + , data = $this.data('dropdown') + if (!data) $this.data('dropdown', (data = new Dropdown(this))) + if (typeof option == 'string') data[option].call($this) + }) + } + + $.fn.dropdown.Constructor = Dropdown + + + /* DROPDOWN NO CONFLICT + * ==================== */ + + $.fn.dropdown.noConflict = function () { + $.fn.dropdown = old + return this + } + + + /* APPLY TO STANDARD DROPDOWN ELEMENTS + * =================================== */ + + $(document) + .on('click.dropdown.data-api touchstart.dropdown.data-api', clearMenus) + .on('click.dropdown touchstart.dropdown.data-api', '.dropdown form', function (e) { e.stopPropagation() }) + .on('touchstart.dropdown.data-api', '.dropdown-menu', function (e) { e.stopPropagation() }) + .on('click.dropdown.data-api touchstart.dropdown.data-api' , toggle, Dropdown.prototype.toggle) + .on('keydown.dropdown.data-api touchstart.dropdown.data-api', toggle + ', [role=menu]' , Dropdown.prototype.keydown) + +}(window.jQuery);/* ========================================================= + * bootstrap-modal.js v2.2.2 + * http://twitter.github.com/bootstrap/javascript.html#modals + * ========================================================= + * Copyright 2012 Twitter, Inc. + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + * ========================================================= */ + + +!function ($) { + + "use strict"; // jshint ;_; + + + /* MODAL CLASS DEFINITION + * ====================== */ + + var Modal = function (element, options) { + this.options = options + this.$element = $(element) + .delegate('[data-dismiss="modal"]', 'click.dismiss.modal', $.proxy(this.hide, this)) + this.options.remote && this.$element.find('.modal-body').load(this.options.remote) + } + + Modal.prototype = { + + constructor: Modal + + , toggle: function () { + return this[!this.isShown ? 'show' : 'hide']() + } + + , show: function () { + var that = this + , e = $.Event('show') + + this.$element.trigger(e) + + if (this.isShown || e.isDefaultPrevented()) return + + this.isShown = true + + this.escape() + + this.backdrop(function () { + var transition = $.support.transition && that.$element.hasClass('fade') + + if (!that.$element.parent().length) { + that.$element.appendTo(document.body) //don't move modals dom position + } + + that.$element + .show() + + if (transition) { + that.$element[0].offsetWidth // force reflow + } + + that.$element + .addClass('in') + .attr('aria-hidden', false) + + that.enforceFocus() + + transition ? + that.$element.one($.support.transition.end, function () { that.$element.focus().trigger('shown') }) : + that.$element.focus().trigger('shown') + + }) + } + + , hide: function (e) { + e && e.preventDefault() + + var that = this + + e = $.Event('hide') + + this.$element.trigger(e) + + if (!this.isShown || e.isDefaultPrevented()) return + + this.isShown = false + + this.escape() + + $(document).off('focusin.modal') + + this.$element + .removeClass('in') + .attr('aria-hidden', true) + + $.support.transition && this.$element.hasClass('fade') ? + this.hideWithTransition() : + this.hideModal() + } + + , enforceFocus: function () { + var that = this + $(document).on('focusin.modal', function (e) { + if (that.$element[0] !== e.target && !that.$element.has(e.target).length) { + that.$element.focus() + } + }) + } + + , escape: function () { + var that = this + if (this.isShown && this.options.keyboard) { + this.$element.on('keyup.dismiss.modal', function ( e ) { + e.which == 27 && that.hide() + }) + } else if (!this.isShown) { + this.$element.off('keyup.dismiss.modal') + } + } + + , hideWithTransition: function () { + var that = this + , timeout = setTimeout(function () { + that.$element.off($.support.transition.end) + that.hideModal() + }, 500) + + this.$element.one($.support.transition.end, function () { + clearTimeout(timeout) + that.hideModal() + }) + } + + , hideModal: function (that) { + this.$element + .hide() + .trigger('hidden') + + this.backdrop() + } + + , removeBackdrop: function () { + this.$backdrop.remove() + this.$backdrop = null + } + + , backdrop: function (callback) { + var that = this + , animate = this.$element.hasClass('fade') ? 'fade' : '' + + if (this.isShown && this.options.backdrop) { + var doAnimate = $.support.transition && animate + + this.$backdrop = $('
') + .appendTo(document.body) + + this.$backdrop.click( + this.options.backdrop == 'static' ? + $.proxy(this.$element[0].focus, this.$element[0]) + : $.proxy(this.hide, this) + ) + + if (doAnimate) this.$backdrop[0].offsetWidth // force reflow + + this.$backdrop.addClass('in') + + doAnimate ? + this.$backdrop.one($.support.transition.end, callback) : + callback() + + } else if (!this.isShown && this.$backdrop) { + this.$backdrop.removeClass('in') + + $.support.transition && this.$element.hasClass('fade')? + this.$backdrop.one($.support.transition.end, $.proxy(this.removeBackdrop, this)) : + this.removeBackdrop() + + } else if (callback) { + callback() + } + } + } + + + /* MODAL PLUGIN DEFINITION + * ======================= */ + + var old = $.fn.modal + + $.fn.modal = function (option) { + return this.each(function () { + var $this = $(this) + , data = $this.data('modal') + , options = $.extend({}, $.fn.modal.defaults, $this.data(), typeof option == 'object' && option) + if (!data) $this.data('modal', (data = new Modal(this, options))) + if (typeof option == 'string') data[option]() + else if (options.show) data.show() + }) + } + + $.fn.modal.defaults = { + backdrop: true + , keyboard: true + , show: true + } + + $.fn.modal.Constructor = Modal + + + /* MODAL NO CONFLICT + * ================= */ + + $.fn.modal.noConflict = function () { + $.fn.modal = old + return this + } + + + /* MODAL DATA-API + * ============== */ + + $(document).on('click.modal.data-api', '[data-toggle="modal"]', function (e) { + var $this = $(this) + , href = $this.attr('href') + , $target = $($this.attr('data-target') || (href && href.replace(/.*(?=#[^\s]+$)/, ''))) //strip for ie7 + , option = $target.data('modal') ? 'toggle' : $.extend({ remote:!/#/.test(href) && href }, $target.data(), $this.data()) + + e.preventDefault() + + $target + .modal(option) + .one('hide', function () { + $this.focus() + }) + }) + +}(window.jQuery); +/* =========================================================== + * bootstrap-tooltip.js v2.2.2 + * http://twitter.github.com/bootstrap/javascript.html#tooltips + * Inspired by the original jQuery.tipsy by Jason Frame + * =========================================================== + * Copyright 2012 Twitter, Inc. + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + * ========================================================== */ + + +!function ($) { + + "use strict"; // jshint ;_; + + + /* TOOLTIP PUBLIC CLASS DEFINITION + * =============================== */ + + var Tooltip = function (element, options) { + this.init('tooltip', element, options) + } + + Tooltip.prototype = { + + constructor: Tooltip + + , init: function (type, element, options) { + var eventIn + , eventOut + + this.type = type + this.$element = $(element) + this.options = this.getOptions(options) + this.enabled = true + + if (this.options.trigger == 'click') { + this.$element.on('click.' + this.type, this.options.selector, $.proxy(this.toggle, this)) + } else if (this.options.trigger != 'manual') { + eventIn = this.options.trigger == 'hover' ? 'mouseenter' : 'focus' + eventOut = this.options.trigger == 'hover' ? 'mouseleave' : 'blur' + this.$element.on(eventIn + '.' + this.type, this.options.selector, $.proxy(this.enter, this)) + this.$element.on(eventOut + '.' + this.type, this.options.selector, $.proxy(this.leave, this)) + } + + this.options.selector ? + (this._options = $.extend({}, this.options, { trigger: 'manual', selector: '' })) : + this.fixTitle() + } + + , getOptions: function (options) { + options = $.extend({}, $.fn[this.type].defaults, options, this.$element.data()) + + if (options.delay && typeof options.delay == 'number') { + options.delay = { + show: options.delay + , hide: options.delay + } + } + + return options + } + + , enter: function (e) { + var self = $(e.currentTarget)[this.type](this._options).data(this.type) + + if (!self.options.delay || !self.options.delay.show) return self.show() + + clearTimeout(this.timeout) + self.hoverState = 'in' + this.timeout = setTimeout(function() { + if (self.hoverState == 'in') self.show() + }, self.options.delay.show) + } + + , leave: function (e) { + var self = $(e.currentTarget)[this.type](this._options).data(this.type) + + if (this.timeout) clearTimeout(this.timeout) + if (!self.options.delay || !self.options.delay.hide) return self.hide() + + self.hoverState = 'out' + this.timeout = setTimeout(function() { + if (self.hoverState == 'out') self.hide() + }, self.options.delay.hide) + } + + , show: function () { + var $tip + , inside + , pos + , actualWidth + , actualHeight + , placement + , tp + + if (this.hasContent() && this.enabled) { + $tip = this.tip() + this.setContent() + + if (this.options.animation) { + $tip.addClass('fade') + } + + placement = typeof this.options.placement == 'function' ? + this.options.placement.call(this, $tip[0], this.$element[0]) : + this.options.placement + + inside = /in/.test(placement) + + $tip + .detach() + .css({ top: 0, left: 0, display: 'block' }) + .insertAfter(this.$element) + + pos = this.getPosition(inside) + + actualWidth = $tip[0].offsetWidth + actualHeight = $tip[0].offsetHeight + + switch (inside ? placement.split(' ')[1] : placement) { + case 'bottom': + tp = {top: pos.top + pos.height, left: pos.left + pos.width / 2 - actualWidth / 2} + break + case 'top': + tp = {top: pos.top - actualHeight, left: pos.left + pos.width / 2 - actualWidth / 2} + break + case 'left': + tp = {top: pos.top + pos.height / 2 - actualHeight / 2, left: pos.left - actualWidth} + break + case 'right': + tp = {top: pos.top + pos.height / 2 - actualHeight / 2, left: pos.left + pos.width} + break + } + + $tip + .offset(tp) + .addClass(placement) + .addClass('in') + } + } + + , setContent: function () { + var $tip = this.tip() + , title = this.getTitle() + + $tip.find('.tooltip-inner')[this.options.html ? 'html' : 'text'](title) + $tip.removeClass('fade in top bottom left right') + } + + , hide: function () { + var that = this + , $tip = this.tip() + + $tip.removeClass('in') + + function removeWithAnimation() { + var timeout = setTimeout(function () { + $tip.off($.support.transition.end).detach() + }, 500) + + $tip.one($.support.transition.end, function () { + clearTimeout(timeout) + $tip.detach() + }) + } + + $.support.transition && this.$tip.hasClass('fade') ? + removeWithAnimation() : + $tip.detach() + + return this + } + + , fixTitle: function () { + var $e = this.$element + if ($e.attr('title') || typeof($e.attr('data-original-title')) != 'string') { + $e.attr('data-original-title', $e.attr('title') || '').removeAttr('title') + } + } + + , hasContent: function () { + return this.getTitle() + } + + , getPosition: function (inside) { + return $.extend({}, (inside ? {top: 0, left: 0} : this.$element.offset()), { + width: this.$element[0].offsetWidth + , height: this.$element[0].offsetHeight + }) + } + + , getTitle: function () { + var title + , $e = this.$element + , o = this.options + + title = $e.attr('data-original-title') + || (typeof o.title == 'function' ? o.title.call($e[0]) : o.title) + + return title + } + + , tip: function () { + return this.$tip = this.$tip || $(this.options.template) + } + + , validate: function () { + if (!this.$element[0].parentNode) { + this.hide() + this.$element = null + this.options = null + } + } + + , enable: function () { + this.enabled = true + } + + , disable: function () { + this.enabled = false + } + + , toggleEnabled: function () { + this.enabled = !this.enabled + } + + , toggle: function (e) { + var self = $(e.currentTarget)[this.type](this._options).data(this.type) + self[self.tip().hasClass('in') ? 'hide' : 'show']() + } + + , destroy: function () { + this.hide().$element.off('.' + this.type).removeData(this.type) + } + + } + + + /* TOOLTIP PLUGIN DEFINITION + * ========================= */ + + var old = $.fn.tooltip + + $.fn.tooltip = function ( option ) { + return this.each(function () { + var $this = $(this) + , data = $this.data('tooltip') + , options = typeof option == 'object' && option + if (!data) $this.data('tooltip', (data = new Tooltip(this, options))) + if (typeof option == 'string') data[option]() + }) + } + + $.fn.tooltip.Constructor = Tooltip + + $.fn.tooltip.defaults = { + animation: true + , placement: 'top' + , selector: false + , template: '
' + , trigger: 'hover' + , title: '' + , delay: 0 + , html: false + } + + + /* TOOLTIP NO CONFLICT + * =================== */ + + $.fn.tooltip.noConflict = function () { + $.fn.tooltip = old + return this + } + +}(window.jQuery);/* =========================================================== + * bootstrap-popover.js v2.2.2 + * http://twitter.github.com/bootstrap/javascript.html#popovers + * =========================================================== + * Copyright 2012 Twitter, Inc. + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + * =========================================================== */ + + +!function ($) { + + "use strict"; // jshint ;_; + + + /* POPOVER PUBLIC CLASS DEFINITION + * =============================== */ + + var Popover = function (element, options) { + this.init('popover', element, options) + } + + + /* NOTE: POPOVER EXTENDS BOOTSTRAP-TOOLTIP.js + ========================================== */ + + Popover.prototype = $.extend({}, $.fn.tooltip.Constructor.prototype, { + + constructor: Popover + + , setContent: function () { + var $tip = this.tip() + , title = this.getTitle() + , content = this.getContent() + + $tip.find('.popover-title')[this.options.html ? 'html' : 'text'](title) + $tip.find('.popover-content')[this.options.html ? 'html' : 'text'](content) + + $tip.removeClass('fade top bottom left right in') + } + + , hasContent: function () { + return this.getTitle() || this.getContent() + } + + , getContent: function () { + var content + , $e = this.$element + , o = this.options + + content = $e.attr('data-content') + || (typeof o.content == 'function' ? o.content.call($e[0]) : o.content) + + return content + } + + , tip: function () { + if (!this.$tip) { + this.$tip = $(this.options.template) + } + return this.$tip + } + + , destroy: function () { + this.hide().$element.off('.' + this.type).removeData(this.type) + } + + }) + + + /* POPOVER PLUGIN DEFINITION + * ======================= */ + + var old = $.fn.popover + + $.fn.popover = function (option) { + return this.each(function () { + var $this = $(this) + , data = $this.data('popover') + , options = typeof option == 'object' && option + if (!data) $this.data('popover', (data = new Popover(this, options))) + if (typeof option == 'string') data[option]() + }) + } + + $.fn.popover.Constructor = Popover + + $.fn.popover.defaults = $.extend({} , $.fn.tooltip.defaults, { + placement: 'right' + , trigger: 'click' + , content: '' + , template: '

' + }) + + + /* POPOVER NO CONFLICT + * =================== */ + + $.fn.popover.noConflict = function () { + $.fn.popover = old + return this + } + +}(window.jQuery);/* ============================================================= + * bootstrap-scrollspy.js v2.2.2 + * http://twitter.github.com/bootstrap/javascript.html#scrollspy + * ============================================================= + * Copyright 2012 Twitter, Inc. + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + * ============================================================== */ + + +!function ($) { + + "use strict"; // jshint ;_; + + + /* SCROLLSPY CLASS DEFINITION + * ========================== */ + + function ScrollSpy(element, options) { + var process = $.proxy(this.process, this) + , $element = $(element).is('body') ? $(window) : $(element) + , href + this.options = $.extend({}, $.fn.scrollspy.defaults, options) + this.$scrollElement = $element.on('scroll.scroll-spy.data-api', process) + this.selector = (this.options.target + || ((href = $(element).attr('href')) && href.replace(/.*(?=#[^\s]+$)/, '')) //strip for ie7 + || '') + ' .nav li > a' + this.$body = $('body') + this.refresh() + this.process() + } + + ScrollSpy.prototype = { + + constructor: ScrollSpy + + , refresh: function () { + var self = this + , $targets + + this.offsets = $([]) + this.targets = $([]) + + $targets = this.$body + .find(this.selector) + .map(function () { + var $el = $(this) + , href = $el.data('target') || $el.attr('href') + , $href = /^#\w/.test(href) && $(href) + return ( $href + && $href.length + && [[ $href.position().top + self.$scrollElement.scrollTop(), href ]] ) || null + }) + .sort(function (a, b) { return a[0] - b[0] }) + .each(function () { + self.offsets.push(this[0]) + self.targets.push(this[1]) + }) + } + + , process: function () { + var scrollTop = this.$scrollElement.scrollTop() + this.options.offset + , scrollHeight = this.$scrollElement[0].scrollHeight || this.$body[0].scrollHeight + , maxScroll = scrollHeight - this.$scrollElement.height() + , offsets = this.offsets + , targets = this.targets + , activeTarget = this.activeTarget + , i + + if (scrollTop >= maxScroll) { + return activeTarget != (i = targets.last()[0]) + && this.activate ( i ) + } + + for (i = offsets.length; i--;) { + activeTarget != targets[i] + && scrollTop >= offsets[i] + && (!offsets[i + 1] || scrollTop <= offsets[i + 1]) + && this.activate( targets[i] ) + } + } + + , activate: function (target) { + var active + , selector + + this.activeTarget = target + + $(this.selector) + .parent('.active') + .removeClass('active') + + selector = this.selector + + '[data-target="' + target + '"],' + + this.selector + '[href="' + target + '"]' + + active = $(selector) + .parent('li') + .addClass('active') + + if (active.parent('.dropdown-menu').length) { + active = active.closest('li.dropdown').addClass('active') + } + + active.trigger('activate') + } + + } + + + /* SCROLLSPY PLUGIN DEFINITION + * =========================== */ + + var old = $.fn.scrollspy + + $.fn.scrollspy = function (option) { + return this.each(function () { + var $this = $(this) + , data = $this.data('scrollspy') + , options = typeof option == 'object' && option + if (!data) $this.data('scrollspy', (data = new ScrollSpy(this, options))) + if (typeof option == 'string') data[option]() + }) + } + + $.fn.scrollspy.Constructor = ScrollSpy + + $.fn.scrollspy.defaults = { + offset: 10 + } + + + /* SCROLLSPY NO CONFLICT + * ===================== */ + + $.fn.scrollspy.noConflict = function () { + $.fn.scrollspy = old + return this + } + + + /* SCROLLSPY DATA-API + * ================== */ + + $(window).on('load', function () { + $('[data-spy="scroll"]').each(function () { + var $spy = $(this) + $spy.scrollspy($spy.data()) + }) + }) + +}(window.jQuery);/* ======================================================== + * bootstrap-tab.js v2.2.2 + * http://twitter.github.com/bootstrap/javascript.html#tabs + * ======================================================== + * Copyright 2012 Twitter, Inc. + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + * ======================================================== */ + + +!function ($) { + + "use strict"; // jshint ;_; + + + /* TAB CLASS DEFINITION + * ==================== */ + + var Tab = function (element) { + this.element = $(element) + } + + Tab.prototype = { + + constructor: Tab + + , show: function () { + var $this = this.element + , $ul = $this.closest('ul:not(.dropdown-menu)') + , selector = $this.attr('data-target') + , previous + , $target + , e + + if (!selector) { + selector = $this.attr('href') + selector = selector && selector.replace(/.*(?=#[^\s]*$)/, '') //strip for ie7 + } + + if ( $this.parent('li').hasClass('active') ) return + + previous = $ul.find('.active:last a')[0] + + e = $.Event('show', { + relatedTarget: previous + }) + + $this.trigger(e) + + if (e.isDefaultPrevented()) return + + $target = $(selector) + + this.activate($this.parent('li'), $ul) + this.activate($target, $target.parent(), function () { + $this.trigger({ + type: 'shown' + , relatedTarget: previous + }) + }) + } + + , activate: function ( element, container, callback) { + var $active = container.find('> .active') + , transition = callback + && $.support.transition + && $active.hasClass('fade') + + function next() { + $active + .removeClass('active') + .find('> .dropdown-menu > .active') + .removeClass('active') + + element.addClass('active') + + if (transition) { + element[0].offsetWidth // reflow for transition + element.addClass('in') + } else { + element.removeClass('fade') + } + + if ( element.parent('.dropdown-menu') ) { + element.closest('li.dropdown').addClass('active') + } + + callback && callback() + } + + transition ? + $active.one($.support.transition.end, next) : + next() + + $active.removeClass('in') + } + } + + + /* TAB PLUGIN DEFINITION + * ===================== */ + + var old = $.fn.tab + + $.fn.tab = function ( option ) { + return this.each(function () { + var $this = $(this) + , data = $this.data('tab') + if (!data) $this.data('tab', (data = new Tab(this))) + if (typeof option == 'string') data[option]() + }) + } + + $.fn.tab.Constructor = Tab + + + /* TAB NO CONFLICT + * =============== */ + + $.fn.tab.noConflict = function () { + $.fn.tab = old + return this + } + + + /* TAB DATA-API + * ============ */ + + $(document).on('click.tab.data-api', '[data-toggle="tab"], [data-toggle="pill"]', function (e) { + e.preventDefault() + $(this).tab('show') + }) + +}(window.jQuery);/* ============================================================= + * bootstrap-typeahead.js v2.2.2 + * http://twitter.github.com/bootstrap/javascript.html#typeahead + * ============================================================= + * Copyright 2012 Twitter, Inc. + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + * ============================================================ */ + + +!function($){ + + "use strict"; // jshint ;_; + + + /* TYPEAHEAD PUBLIC CLASS DEFINITION + * ================================= */ + + var Typeahead = function (element, options) { + this.$element = $(element) + this.options = $.extend({}, $.fn.typeahead.defaults, options) + this.matcher = this.options.matcher || this.matcher + this.sorter = this.options.sorter || this.sorter + this.highlighter = this.options.highlighter || this.highlighter + this.updater = this.options.updater || this.updater + this.source = this.options.source + this.$menu = $(this.options.menu) + this.shown = false + this.listen() + } + + Typeahead.prototype = { + + constructor: Typeahead + + , select: function () { + var val = this.$menu.find('.active').attr('data-value') + this.$element + .val(this.updater(val)) + .change() + return this.hide() + } + + , updater: function (item) { + return item + } + + , show: function () { + var pos = $.extend({}, this.$element.position(), { + height: this.$element[0].offsetHeight + }) + + this.$menu + .insertAfter(this.$element) + .css({ + top: pos.top + pos.height + , left: pos.left + }) + .show() + + this.shown = true + return this + } + + , hide: function () { + this.$menu.hide() + this.shown = false + return this + } + + , lookup: function (event) { + var items + + this.query = this.$element.val() + + if (!this.query || this.query.length < this.options.minLength) { + return this.shown ? this.hide() : this + } + + items = $.isFunction(this.source) ? this.source(this.query, $.proxy(this.process, this)) : this.source + + return items ? this.process(items) : this + } + + , process: function (items) { + var that = this + + items = $.grep(items, function (item) { + return that.matcher(item) + }) + + items = this.sorter(items) + + if (!items.length) { + return this.shown ? this.hide() : this + } + + return this.render(items.slice(0, this.options.items)).show() + } + + , matcher: function (item) { + return ~item.toLowerCase().indexOf(this.query.toLowerCase()) + } + + , sorter: function (items) { + var beginswith = [] + , caseSensitive = [] + , caseInsensitive = [] + , item + + while (item = items.shift()) { + if (!item.toLowerCase().indexOf(this.query.toLowerCase())) beginswith.push(item) + else if (~item.indexOf(this.query)) caseSensitive.push(item) + else caseInsensitive.push(item) + } + + return beginswith.concat(caseSensitive, caseInsensitive) + } + + , highlighter: function (item) { + var query = this.query.replace(/[\-\[\]{}()*+?.,\\\^$|#\s]/g, '\\$&') + return item.replace(new RegExp('(' + query + ')', 'ig'), function ($1, match) { + return '' + match + '' + }) + } + + , render: function (items) { + var that = this + + items = $(items).map(function (i, item) { + i = $(that.options.item).attr('data-value', item) + i.find('a').html(that.highlighter(item)) + return i[0] + }) + + items.first().addClass('active') + this.$menu.html(items) + return this + } + + , next: function (event) { + var active = this.$menu.find('.active').removeClass('active') + , next = active.next() + + if (!next.length) { + next = $(this.$menu.find('li')[0]) + } + + next.addClass('active') + } + + , prev: function (event) { + var active = this.$menu.find('.active').removeClass('active') + , prev = active.prev() + + if (!prev.length) { + prev = this.$menu.find('li').last() + } + + prev.addClass('active') + } + + , listen: function () { + this.$element + .on('blur', $.proxy(this.blur, this)) + .on('keypress', $.proxy(this.keypress, this)) + .on('keyup', $.proxy(this.keyup, this)) + + if (this.eventSupported('keydown')) { + this.$element.on('keydown', $.proxy(this.keydown, this)) + } + + this.$menu + .on('click', $.proxy(this.click, this)) + .on('mouseenter', 'li', $.proxy(this.mouseenter, this)) + } + + , eventSupported: function(eventName) { + var isSupported = eventName in this.$element + if (!isSupported) { + this.$element.setAttribute(eventName, 'return;') + isSupported = typeof this.$element[eventName] === 'function' + } + return isSupported + } + + , move: function (e) { + if (!this.shown) return + + switch(e.keyCode) { + case 9: // tab + case 13: // enter + case 27: // escape + e.preventDefault() + break + + case 38: // up arrow + e.preventDefault() + this.prev() + break + + case 40: // down arrow + e.preventDefault() + this.next() + break + } + + e.stopPropagation() + } + + , keydown: function (e) { + this.suppressKeyPressRepeat = ~$.inArray(e.keyCode, [40,38,9,13,27]) + this.move(e) + } + + , keypress: function (e) { + if (this.suppressKeyPressRepeat) return + this.move(e) + } + + , keyup: function (e) { + switch(e.keyCode) { + case 40: // down arrow + case 38: // up arrow + case 16: // shift + case 17: // ctrl + case 18: // alt + break + + case 9: // tab + case 13: // enter + if (!this.shown) return + this.select() + break + + case 27: // escape + if (!this.shown) return + this.hide() + break + + default: + this.lookup() + } + + e.stopPropagation() + e.preventDefault() + } + + , blur: function (e) { + var that = this + setTimeout(function () { that.hide() }, 150) + } + + , click: function (e) { + e.stopPropagation() + e.preventDefault() + this.select() + } + + , mouseenter: function (e) { + this.$menu.find('.active').removeClass('active') + $(e.currentTarget).addClass('active') + } + + } + + + /* TYPEAHEAD PLUGIN DEFINITION + * =========================== */ + + var old = $.fn.typeahead + + $.fn.typeahead = function (option) { + return this.each(function () { + var $this = $(this) + , data = $this.data('typeahead') + , options = typeof option == 'object' && option + if (!data) $this.data('typeahead', (data = new Typeahead(this, options))) + if (typeof option == 'string') data[option]() + }) + } + + $.fn.typeahead.defaults = { + source: [] + , items: 8 + , menu: '
    ' + , item: '
    • ' + , minLength: 1 + } + + $.fn.typeahead.Constructor = Typeahead + + + /* TYPEAHEAD NO CONFLICT + * =================== */ + + $.fn.typeahead.noConflict = function () { + $.fn.typeahead = old + return this + } + + + /* TYPEAHEAD DATA-API + * ================== */ + + $(document).on('focus.typeahead.data-api', '[data-provide="typeahead"]', function (e) { + var $this = $(this) + if ($this.data('typeahead')) return + e.preventDefault() + $this.typeahead($this.data()) + }) + +}(window.jQuery); +/* ========================================================== + * bootstrap-affix.js v2.2.2 + * http://twitter.github.com/bootstrap/javascript.html#affix + * ========================================================== + * Copyright 2012 Twitter, Inc. + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + * ========================================================== */ + + +!function ($) { + + "use strict"; // jshint ;_; + + + /* AFFIX CLASS DEFINITION + * ====================== */ + + var Affix = function (element, options) { + this.options = $.extend({}, $.fn.affix.defaults, options) + this.$window = $(window) + .on('scroll.affix.data-api', $.proxy(this.checkPosition, this)) + .on('click.affix.data-api', $.proxy(function () { setTimeout($.proxy(this.checkPosition, this), 1) }, this)) + this.$element = $(element) + this.checkPosition() + } + + Affix.prototype.checkPosition = function () { + if (!this.$element.is(':visible')) return + + var scrollHeight = $(document).height() + , scrollTop = this.$window.scrollTop() + , position = this.$element.offset() + , offset = this.options.offset + , offsetBottom = offset.bottom + , offsetTop = offset.top + , reset = 'affix affix-top affix-bottom' + , affix + + if (typeof offset != 'object') offsetBottom = offsetTop = offset + if (typeof offsetTop == 'function') offsetTop = offset.top() + if (typeof offsetBottom == 'function') offsetBottom = offset.bottom() + + affix = this.unpin != null && (scrollTop + this.unpin <= position.top) ? + false : offsetBottom != null && (position.top + this.$element.height() >= scrollHeight - offsetBottom) ? + 'bottom' : offsetTop != null && scrollTop <= offsetTop ? + 'top' : false + + if (this.affixed === affix) return + + this.affixed = affix + this.unpin = affix == 'bottom' ? position.top - scrollTop : null + + this.$element.removeClass(reset).addClass('affix' + (affix ? '-' + affix : '')) + } + + + /* AFFIX PLUGIN DEFINITION + * ======================= */ + + var old = $.fn.affix + + $.fn.affix = function (option) { + return this.each(function () { + var $this = $(this) + , data = $this.data('affix') + , options = typeof option == 'object' && option + if (!data) $this.data('affix', (data = new Affix(this, options))) + if (typeof option == 'string') data[option]() + }) + } + + $.fn.affix.Constructor = Affix + + $.fn.affix.defaults = { + offset: 0 + } + + + /* AFFIX NO CONFLICT + * ================= */ + + $.fn.affix.noConflict = function () { + $.fn.affix = old + return this + } + + + /* AFFIX DATA-API + * ============== */ + + $(window).on('load', function () { + $('[data-spy="affix"]').each(function () { + var $spy = $(this) + , data = $spy.data() + + data.offset = data.offset || {} + + data.offsetBottom && (data.offset.bottom = data.offsetBottom) + data.offsetTop && (data.offset.top = data.offsetTop) + + $spy.affix(data) + }) + }) + + +}(window.jQuery); \ No newline at end of file diff --git a/website/js/bootstrap.min.js b/website/js/bootstrap.min.js new file mode 100644 index 00000000..6eeb15ce --- /dev/null +++ b/website/js/bootstrap.min.js @@ -0,0 +1,6 @@ +/*! +* Bootstrap.js by @fat & @mdo +* Copyright 2012 Twitter, Inc. +* http://www.apache.org/licenses/LICENSE-2.0.txt +*/ +!function($){"use strict";$(function(){$.support.transition=function(){var transitionEnd=function(){var name,el=document.createElement("bootstrap"),transEndEventNames={WebkitTransition:"webkitTransitionEnd",MozTransition:"transitionend",OTransition:"oTransitionEnd otransitionend",transition:"transitionend"};for(name in transEndEventNames)if(void 0!==el.style[name])return transEndEventNames[name]}();return transitionEnd&&{end:transitionEnd}}()})}(window.jQuery),!function($){"use strict";var dismiss='[data-dismiss="alert"]',Alert=function(el){$(el).on("click",dismiss,this.close)};Alert.prototype.close=function(e){function removeElement(){$parent.trigger("closed").remove()}var $parent,$this=$(this),selector=$this.attr("data-target");selector||(selector=$this.attr("href"),selector=selector&&selector.replace(/.*(?=#[^\s]*$)/,"")),$parent=$(selector),e&&e.preventDefault(),$parent.length||($parent=$this.hasClass("alert")?$this:$this.parent()),$parent.trigger(e=$.Event("close")),e.isDefaultPrevented()||($parent.removeClass("in"),$.support.transition&&$parent.hasClass("fade")?$parent.on($.support.transition.end,removeElement):removeElement())};var old=$.fn.alert;$.fn.alert=function(option){return this.each(function(){var $this=$(this),data=$this.data("alert");data||$this.data("alert",data=new Alert(this)),"string"==typeof option&&data[option].call($this)})},$.fn.alert.Constructor=Alert,$.fn.alert.noConflict=function(){return $.fn.alert=old,this},$(document).on("click.alert.data-api",dismiss,Alert.prototype.close)}(window.jQuery),!function($){"use strict";var Button=function(element,options){this.$element=$(element),this.options=$.extend({},$.fn.button.defaults,options)};Button.prototype.setState=function(state){var d="disabled",$el=this.$element,data=$el.data(),val=$el.is("input")?"val":"html";state+="Text",data.resetText||$el.data("resetText",$el[val]()),$el[val](data[state]||this.options[state]),setTimeout(function(){"loadingText"==state?$el.addClass(d).attr(d,d):$el.removeClass(d).removeAttr(d)},0)},Button.prototype.toggle=function(){var $parent=this.$element.closest('[data-toggle="buttons-radio"]');$parent&&$parent.find(".active").removeClass("active"),this.$element.toggleClass("active")};var old=$.fn.button;$.fn.button=function(option){return this.each(function(){var $this=$(this),data=$this.data("button"),options="object"==typeof option&&option;data||$this.data("button",data=new Button(this,options)),"toggle"==option?data.toggle():option&&data.setState(option)})},$.fn.button.defaults={loadingText:"loading..."},$.fn.button.Constructor=Button,$.fn.button.noConflict=function(){return $.fn.button=old,this},$(document).on("click.button.data-api","[data-toggle^=button]",function(e){var $btn=$(e.target);$btn.hasClass("btn")||($btn=$btn.closest(".btn")),$btn.button("toggle")})}(window.jQuery),!function($){"use strict";var Carousel=function(element,options){this.$element=$(element),this.options=options,"hover"==this.options.pause&&this.$element.on("mouseenter",$.proxy(this.pause,this)).on("mouseleave",$.proxy(this.cycle,this))};Carousel.prototype={cycle:function(e){return e||(this.paused=!1),this.options.interval&&!this.paused&&(this.interval=setInterval($.proxy(this.next,this),this.options.interval)),this},to:function(pos){var $active=this.$element.find(".item.active"),children=$active.parent().children(),activePos=children.index($active),that=this;if(!(pos>children.length-1||0>pos))return this.sliding?this.$element.one("slid",function(){that.to(pos)}):activePos==pos?this.pause().cycle():this.slide(pos>activePos?"next":"prev",$(children[pos]))},pause:function(e){return e||(this.paused=!0),this.$element.find(".next, .prev").length&&$.support.transition.end&&(this.$element.trigger($.support.transition.end),this.cycle()),clearInterval(this.interval),this.interval=null,this},next:function(){return this.sliding?void 0:this.slide("next")},prev:function(){return this.sliding?void 0:this.slide("prev")},slide:function(type,next){var e,$active=this.$element.find(".item.active"),$next=next||$active[type](),isCycling=this.interval,direction="next"==type?"left":"right",fallback="next"==type?"first":"last",that=this;if(this.sliding=!0,isCycling&&this.pause(),$next=$next.length?$next:this.$element.find(".item")[fallback](),e=$.Event("slide",{relatedTarget:$next[0]}),!$next.hasClass("active")){if($.support.transition&&this.$element.hasClass("slide")){if(this.$element.trigger(e),e.isDefaultPrevented())return;$next.addClass(type),$next[0].offsetWidth,$active.addClass(direction),$next.addClass(direction),this.$element.one($.support.transition.end,function(){$next.removeClass([type,direction].join(" ")).addClass("active"),$active.removeClass(["active",direction].join(" ")),that.sliding=!1,setTimeout(function(){that.$element.trigger("slid")},0)})}else{if(this.$element.trigger(e),e.isDefaultPrevented())return;$active.removeClass("active"),$next.addClass("active"),this.sliding=!1,this.$element.trigger("slid")}return isCycling&&this.cycle(),this}}};var old=$.fn.carousel;$.fn.carousel=function(option){return this.each(function(){var $this=$(this),data=$this.data("carousel"),options=$.extend({},$.fn.carousel.defaults,"object"==typeof option&&option),action="string"==typeof option?option:options.slide;data||$this.data("carousel",data=new Carousel(this,options)),"number"==typeof option?data.to(option):action?data[action]():options.interval&&data.cycle()})},$.fn.carousel.defaults={interval:5e3,pause:"hover"},$.fn.carousel.Constructor=Carousel,$.fn.carousel.noConflict=function(){return $.fn.carousel=old,this},$(document).on("click.carousel.data-api","[data-slide]",function(e){var href,$this=$(this),$target=$($this.attr("data-target")||(href=$this.attr("href"))&&href.replace(/.*(?=#[^\s]+$)/,"")),options=$.extend({},$target.data(),$this.data());$target.carousel(options),e.preventDefault()})}(window.jQuery),!function($){"use strict";var Collapse=function(element,options){this.$element=$(element),this.options=$.extend({},$.fn.collapse.defaults,options),this.options.parent&&(this.$parent=$(this.options.parent)),this.options.toggle&&this.toggle()};Collapse.prototype={constructor:Collapse,dimension:function(){var hasWidth=this.$element.hasClass("width");return hasWidth?"width":"height"},show:function(){var dimension,scroll,actives,hasData;if(!this.transitioning){if(dimension=this.dimension(),scroll=$.camelCase(["scroll",dimension].join("-")),actives=this.$parent&&this.$parent.find("> .accordion-group > .in"),actives&&actives.length){if(hasData=actives.data("collapse"),hasData&&hasData.transitioning)return;actives.collapse("hide"),hasData||actives.data("collapse",null)}this.$element[dimension](0),this.transition("addClass",$.Event("show"),"shown"),$.support.transition&&this.$element[dimension](this.$element[0][scroll])}},hide:function(){var dimension;this.transitioning||(dimension=this.dimension(),this.reset(this.$element[dimension]()),this.transition("removeClass",$.Event("hide"),"hidden"),this.$element[dimension](0))},reset:function(size){var dimension=this.dimension();return this.$element.removeClass("collapse")[dimension](size||"auto")[0].offsetWidth,this.$element[null!==size?"addClass":"removeClass"]("collapse"),this},transition:function(method,startEvent,completeEvent){var that=this,complete=function(){"show"==startEvent.type&&that.reset(),that.transitioning=0,that.$element.trigger(completeEvent)};this.$element.trigger(startEvent),startEvent.isDefaultPrevented()||(this.transitioning=1,this.$element[method]("in"),$.support.transition&&this.$element.hasClass("collapse")?this.$element.one($.support.transition.end,complete):complete())},toggle:function(){this[this.$element.hasClass("in")?"hide":"show"]()}};var old=$.fn.collapse;$.fn.collapse=function(option){return this.each(function(){var $this=$(this),data=$this.data("collapse"),options="object"==typeof option&&option;data||$this.data("collapse",data=new Collapse(this,options)),"string"==typeof option&&data[option]()})},$.fn.collapse.defaults={toggle:!0},$.fn.collapse.Constructor=Collapse,$.fn.collapse.noConflict=function(){return $.fn.collapse=old,this},$(document).on("click.collapse.data-api","[data-toggle=collapse]",function(e){var href,$this=$(this),target=$this.attr("data-target")||e.preventDefault()||(href=$this.attr("href"))&&href.replace(/.*(?=#[^\s]+$)/,""),option=$(target).data("collapse")?"toggle":$this.data();$this[$(target).hasClass("in")?"addClass":"removeClass"]("collapsed"),$(target).collapse(option)})}(window.jQuery),!function($){"use strict";function clearMenus(){$(toggle).each(function(){getParent($(this)).removeClass("open")})}function getParent($this){var $parent,selector=$this.attr("data-target");return selector||(selector=$this.attr("href"),selector=selector&&/#/.test(selector)&&selector.replace(/.*(?=#[^\s]*$)/,"")),$parent=$(selector),$parent.length||($parent=$this.parent()),$parent}var toggle="[data-toggle=dropdown]",Dropdown=function(element){var $el=$(element).on("click.dropdown.data-api",this.toggle);$("html").on("click.dropdown.data-api",function(){$el.parent().removeClass("open")})};Dropdown.prototype={constructor:Dropdown,toggle:function(){var $parent,isActive,$this=$(this);if(!$this.is(".disabled, :disabled"))return $parent=getParent($this),isActive=$parent.hasClass("open"),clearMenus(),isActive||$parent.toggleClass("open"),$this.focus(),!1},keydown:function(e){var $this,$items,$parent,isActive,index;if(/(38|40|27)/.test(e.keyCode)&&($this=$(this),e.preventDefault(),e.stopPropagation(),!$this.is(".disabled, :disabled"))){if($parent=getParent($this),isActive=$parent.hasClass("open"),!isActive||isActive&&27==e.keyCode)return $this.click();$items=$("[role=menu] li:not(.divider):visible a",$parent),$items.length&&(index=$items.index($items.filter(":focus")),38==e.keyCode&&index>0&&index--,40==e.keyCode&&$items.length-1>index&&index++,~index||(index=0),$items.eq(index).focus())}}};var old=$.fn.dropdown;$.fn.dropdown=function(option){return this.each(function(){var $this=$(this),data=$this.data("dropdown");data||$this.data("dropdown",data=new Dropdown(this)),"string"==typeof option&&data[option].call($this)})},$.fn.dropdown.Constructor=Dropdown,$.fn.dropdown.noConflict=function(){return $.fn.dropdown=old,this},$(document).on("click.dropdown.data-api touchstart.dropdown.data-api",clearMenus).on("click.dropdown touchstart.dropdown.data-api",".dropdown form",function(e){e.stopPropagation()}).on("touchstart.dropdown.data-api",".dropdown-menu",function(e){e.stopPropagation()}).on("click.dropdown.data-api touchstart.dropdown.data-api",toggle,Dropdown.prototype.toggle).on("keydown.dropdown.data-api touchstart.dropdown.data-api",toggle+", [role=menu]",Dropdown.prototype.keydown)}(window.jQuery),!function($){"use strict";var Modal=function(element,options){this.options=options,this.$element=$(element).delegate('[data-dismiss="modal"]',"click.dismiss.modal",$.proxy(this.hide,this)),this.options.remote&&this.$element.find(".modal-body").load(this.options.remote)};Modal.prototype={constructor:Modal,toggle:function(){return this[this.isShown?"hide":"show"]()},show:function(){var that=this,e=$.Event("show");this.$element.trigger(e),this.isShown||e.isDefaultPrevented()||(this.isShown=!0,this.escape(),this.backdrop(function(){var transition=$.support.transition&&that.$element.hasClass("fade");that.$element.parent().length||that.$element.appendTo(document.body),that.$element.show(),transition&&that.$element[0].offsetWidth,that.$element.addClass("in").attr("aria-hidden",!1),that.enforceFocus(),transition?that.$element.one($.support.transition.end,function(){that.$element.focus().trigger("shown")}):that.$element.focus().trigger("shown")}))},hide:function(e){e&&e.preventDefault(),e=$.Event("hide"),this.$element.trigger(e),this.isShown&&!e.isDefaultPrevented()&&(this.isShown=!1,this.escape(),$(document).off("focusin.modal"),this.$element.removeClass("in").attr("aria-hidden",!0),$.support.transition&&this.$element.hasClass("fade")?this.hideWithTransition():this.hideModal())},enforceFocus:function(){var that=this;$(document).on("focusin.modal",function(e){that.$element[0]===e.target||that.$element.has(e.target).length||that.$element.focus()})},escape:function(){var that=this;this.isShown&&this.options.keyboard?this.$element.on("keyup.dismiss.modal",function(e){27==e.which&&that.hide()}):this.isShown||this.$element.off("keyup.dismiss.modal")},hideWithTransition:function(){var that=this,timeout=setTimeout(function(){that.$element.off($.support.transition.end),that.hideModal()},500);this.$element.one($.support.transition.end,function(){clearTimeout(timeout),that.hideModal()})},hideModal:function(){this.$element.hide().trigger("hidden"),this.backdrop()},removeBackdrop:function(){this.$backdrop.remove(),this.$backdrop=null},backdrop:function(callback){var animate=this.$element.hasClass("fade")?"fade":"";if(this.isShown&&this.options.backdrop){var doAnimate=$.support.transition&&animate;this.$backdrop=$('
    ').appendTo(document.body),this.$backdrop.click("static"==this.options.backdrop?$.proxy(this.$element[0].focus,this.$element[0]):$.proxy(this.hide,this)),doAnimate&&this.$backdrop[0].offsetWidth,this.$backdrop.addClass("in"),doAnimate?this.$backdrop.one($.support.transition.end,callback):callback()}else!this.isShown&&this.$backdrop?(this.$backdrop.removeClass("in"),$.support.transition&&this.$element.hasClass("fade")?this.$backdrop.one($.support.transition.end,$.proxy(this.removeBackdrop,this)):this.removeBackdrop()):callback&&callback()}};var old=$.fn.modal;$.fn.modal=function(option){return this.each(function(){var $this=$(this),data=$this.data("modal"),options=$.extend({},$.fn.modal.defaults,$this.data(),"object"==typeof option&&option);data||$this.data("modal",data=new Modal(this,options)),"string"==typeof option?data[option]():options.show&&data.show()})},$.fn.modal.defaults={backdrop:!0,keyboard:!0,show:!0},$.fn.modal.Constructor=Modal,$.fn.modal.noConflict=function(){return $.fn.modal=old,this},$(document).on("click.modal.data-api",'[data-toggle="modal"]',function(e){var $this=$(this),href=$this.attr("href"),$target=$($this.attr("data-target")||href&&href.replace(/.*(?=#[^\s]+$)/,"")),option=$target.data("modal")?"toggle":$.extend({remote:!/#/.test(href)&&href},$target.data(),$this.data());e.preventDefault(),$target.modal(option).one("hide",function(){$this.focus()})})}(window.jQuery),!function($){"use strict";var Tooltip=function(element,options){this.init("tooltip",element,options)};Tooltip.prototype={constructor:Tooltip,init:function(type,element,options){var eventIn,eventOut;this.type=type,this.$element=$(element),this.options=this.getOptions(options),this.enabled=!0,"click"==this.options.trigger?this.$element.on("click."+this.type,this.options.selector,$.proxy(this.toggle,this)):"manual"!=this.options.trigger&&(eventIn="hover"==this.options.trigger?"mouseenter":"focus",eventOut="hover"==this.options.trigger?"mouseleave":"blur",this.$element.on(eventIn+"."+this.type,this.options.selector,$.proxy(this.enter,this)),this.$element.on(eventOut+"."+this.type,this.options.selector,$.proxy(this.leave,this))),this.options.selector?this._options=$.extend({},this.options,{trigger:"manual",selector:""}):this.fixTitle()},getOptions:function(options){return options=$.extend({},$.fn[this.type].defaults,options,this.$element.data()),options.delay&&"number"==typeof options.delay&&(options.delay={show:options.delay,hide:options.delay}),options},enter:function(e){var self=$(e.currentTarget)[this.type](this._options).data(this.type);return self.options.delay&&self.options.delay.show?(clearTimeout(this.timeout),self.hoverState="in",this.timeout=setTimeout(function(){"in"==self.hoverState&&self.show()},self.options.delay.show),void 0):self.show()},leave:function(e){var self=$(e.currentTarget)[this.type](this._options).data(this.type);return this.timeout&&clearTimeout(this.timeout),self.options.delay&&self.options.delay.hide?(self.hoverState="out",this.timeout=setTimeout(function(){"out"==self.hoverState&&self.hide()},self.options.delay.hide),void 0):self.hide()},show:function(){var $tip,inside,pos,actualWidth,actualHeight,placement,tp;if(this.hasContent()&&this.enabled){switch($tip=this.tip(),this.setContent(),this.options.animation&&$tip.addClass("fade"),placement="function"==typeof this.options.placement?this.options.placement.call(this,$tip[0],this.$element[0]):this.options.placement,inside=/in/.test(placement),$tip.detach().css({top:0,left:0,display:"block"}).insertAfter(this.$element),pos=this.getPosition(inside),actualWidth=$tip[0].offsetWidth,actualHeight=$tip[0].offsetHeight,inside?placement.split(" ")[1]:placement){case"bottom":tp={top:pos.top+pos.height,left:pos.left+pos.width/2-actualWidth/2};break;case"top":tp={top:pos.top-actualHeight,left:pos.left+pos.width/2-actualWidth/2};break;case"left":tp={top:pos.top+pos.height/2-actualHeight/2,left:pos.left-actualWidth};break;case"right":tp={top:pos.top+pos.height/2-actualHeight/2,left:pos.left+pos.width}}$tip.offset(tp).addClass(placement).addClass("in")}},setContent:function(){var $tip=this.tip(),title=this.getTitle();$tip.find(".tooltip-inner")[this.options.html?"html":"text"](title),$tip.removeClass("fade in top bottom left right")},hide:function(){function removeWithAnimation(){var timeout=setTimeout(function(){$tip.off($.support.transition.end).detach()},500);$tip.one($.support.transition.end,function(){clearTimeout(timeout),$tip.detach()})}var $tip=this.tip();return $tip.removeClass("in"),$.support.transition&&this.$tip.hasClass("fade")?removeWithAnimation():$tip.detach(),this},fixTitle:function(){var $e=this.$element;($e.attr("title")||"string"!=typeof $e.attr("data-original-title"))&&$e.attr("data-original-title",$e.attr("title")||"").removeAttr("title")},hasContent:function(){return this.getTitle()},getPosition:function(inside){return $.extend({},inside?{top:0,left:0}:this.$element.offset(),{width:this.$element[0].offsetWidth,height:this.$element[0].offsetHeight})},getTitle:function(){var title,$e=this.$element,o=this.options;return title=$e.attr("data-original-title")||("function"==typeof o.title?o.title.call($e[0]):o.title)},tip:function(){return this.$tip=this.$tip||$(this.options.template)},validate:function(){this.$element[0].parentNode||(this.hide(),this.$element=null,this.options=null)},enable:function(){this.enabled=!0},disable:function(){this.enabled=!1},toggleEnabled:function(){this.enabled=!this.enabled},toggle:function(e){var self=$(e.currentTarget)[this.type](this._options).data(this.type);self[self.tip().hasClass("in")?"hide":"show"]()},destroy:function(){this.hide().$element.off("."+this.type).removeData(this.type)}};var old=$.fn.tooltip;$.fn.tooltip=function(option){return this.each(function(){var $this=$(this),data=$this.data("tooltip"),options="object"==typeof option&&option;data||$this.data("tooltip",data=new Tooltip(this,options)),"string"==typeof option&&data[option]()})},$.fn.tooltip.Constructor=Tooltip,$.fn.tooltip.defaults={animation:!0,placement:"top",selector:!1,template:'
    ',trigger:"hover",title:"",delay:0,html:!1},$.fn.tooltip.noConflict=function(){return $.fn.tooltip=old,this}}(window.jQuery),!function($){"use strict";var Popover=function(element,options){this.init("popover",element,options)};Popover.prototype=$.extend({},$.fn.tooltip.Constructor.prototype,{constructor:Popover,setContent:function(){var $tip=this.tip(),title=this.getTitle(),content=this.getContent();$tip.find(".popover-title")[this.options.html?"html":"text"](title),$tip.find(".popover-content")[this.options.html?"html":"text"](content),$tip.removeClass("fade top bottom left right in")},hasContent:function(){return this.getTitle()||this.getContent()},getContent:function(){var content,$e=this.$element,o=this.options;return content=$e.attr("data-content")||("function"==typeof o.content?o.content.call($e[0]):o.content)},tip:function(){return this.$tip||(this.$tip=$(this.options.template)),this.$tip},destroy:function(){this.hide().$element.off("."+this.type).removeData(this.type)}});var old=$.fn.popover;$.fn.popover=function(option){return this.each(function(){var $this=$(this),data=$this.data("popover"),options="object"==typeof option&&option;data||$this.data("popover",data=new Popover(this,options)),"string"==typeof option&&data[option]()})},$.fn.popover.Constructor=Popover,$.fn.popover.defaults=$.extend({},$.fn.tooltip.defaults,{placement:"right",trigger:"click",content:"",template:'

    '}),$.fn.popover.noConflict=function(){return $.fn.popover=old,this}}(window.jQuery),!function($){"use strict";function ScrollSpy(element,options){var href,process=$.proxy(this.process,this),$element=$(element).is("body")?$(window):$(element);this.options=$.extend({},$.fn.scrollspy.defaults,options),this.$scrollElement=$element.on("scroll.scroll-spy.data-api",process),this.selector=(this.options.target||(href=$(element).attr("href"))&&href.replace(/.*(?=#[^\s]+$)/,"")||"")+" .nav li > a",this.$body=$("body"),this.refresh(),this.process()}ScrollSpy.prototype={constructor:ScrollSpy,refresh:function(){var $targets,self=this;this.offsets=$([]),this.targets=$([]),$targets=this.$body.find(this.selector).map(function(){var $el=$(this),href=$el.data("target")||$el.attr("href"),$href=/^#\w/.test(href)&&$(href);return $href&&$href.length&&[[$href.position().top+self.$scrollElement.scrollTop(),href]]||null}).sort(function(a,b){return a[0]-b[0]}).each(function(){self.offsets.push(this[0]),self.targets.push(this[1])})},process:function(){var i,scrollTop=this.$scrollElement.scrollTop()+this.options.offset,scrollHeight=this.$scrollElement[0].scrollHeight||this.$body[0].scrollHeight,maxScroll=scrollHeight-this.$scrollElement.height(),offsets=this.offsets,targets=this.targets,activeTarget=this.activeTarget;if(scrollTop>=maxScroll)return activeTarget!=(i=targets.last()[0])&&this.activate(i);for(i=offsets.length;i--;)activeTarget!=targets[i]&&scrollTop>=offsets[i]&&(!offsets[i+1]||offsets[i+1]>=scrollTop)&&this.activate(targets[i])},activate:function(target){var active,selector;this.activeTarget=target,$(this.selector).parent(".active").removeClass("active"),selector=this.selector+'[data-target="'+target+'"],'+this.selector+'[href="'+target+'"]',active=$(selector).parent("li").addClass("active"),active.parent(".dropdown-menu").length&&(active=active.closest("li.dropdown").addClass("active")),active.trigger("activate")}};var old=$.fn.scrollspy;$.fn.scrollspy=function(option){return this.each(function(){var $this=$(this),data=$this.data("scrollspy"),options="object"==typeof option&&option;data||$this.data("scrollspy",data=new ScrollSpy(this,options)),"string"==typeof option&&data[option]()})},$.fn.scrollspy.Constructor=ScrollSpy,$.fn.scrollspy.defaults={offset:10},$.fn.scrollspy.noConflict=function(){return $.fn.scrollspy=old,this},$(window).on("load",function(){$('[data-spy="scroll"]').each(function(){var $spy=$(this);$spy.scrollspy($spy.data())})})}(window.jQuery),!function($){"use strict";var Tab=function(element){this.element=$(element)};Tab.prototype={constructor:Tab,show:function(){var previous,$target,e,$this=this.element,$ul=$this.closest("ul:not(.dropdown-menu)"),selector=$this.attr("data-target");selector||(selector=$this.attr("href"),selector=selector&&selector.replace(/.*(?=#[^\s]*$)/,"")),$this.parent("li").hasClass("active")||(previous=$ul.find(".active:last a")[0],e=$.Event("show",{relatedTarget:previous}),$this.trigger(e),e.isDefaultPrevented()||($target=$(selector),this.activate($this.parent("li"),$ul),this.activate($target,$target.parent(),function(){$this.trigger({type:"shown",relatedTarget:previous})})))},activate:function(element,container,callback){function next(){$active.removeClass("active").find("> .dropdown-menu > .active").removeClass("active"),element.addClass("active"),transition?(element[0].offsetWidth,element.addClass("in")):element.removeClass("fade"),element.parent(".dropdown-menu")&&element.closest("li.dropdown").addClass("active"),callback&&callback()}var $active=container.find("> .active"),transition=callback&&$.support.transition&&$active.hasClass("fade");transition?$active.one($.support.transition.end,next):next(),$active.removeClass("in")}};var old=$.fn.tab;$.fn.tab=function(option){return this.each(function(){var $this=$(this),data=$this.data("tab");data||$this.data("tab",data=new Tab(this)),"string"==typeof option&&data[option]()})},$.fn.tab.Constructor=Tab,$.fn.tab.noConflict=function(){return $.fn.tab=old,this},$(document).on("click.tab.data-api",'[data-toggle="tab"], [data-toggle="pill"]',function(e){e.preventDefault(),$(this).tab("show")})}(window.jQuery),!function($){"use strict";var Typeahead=function(element,options){this.$element=$(element),this.options=$.extend({},$.fn.typeahead.defaults,options),this.matcher=this.options.matcher||this.matcher,this.sorter=this.options.sorter||this.sorter,this.highlighter=this.options.highlighter||this.highlighter,this.updater=this.options.updater||this.updater,this.source=this.options.source,this.$menu=$(this.options.menu),this.shown=!1,this.listen()};Typeahead.prototype={constructor:Typeahead,select:function(){var val=this.$menu.find(".active").attr("data-value");return this.$element.val(this.updater(val)).change(),this.hide()},updater:function(item){return item},show:function(){var pos=$.extend({},this.$element.position(),{height:this.$element[0].offsetHeight});return this.$menu.insertAfter(this.$element).css({top:pos.top+pos.height,left:pos.left}).show(),this.shown=!0,this},hide:function(){return this.$menu.hide(),this.shown=!1,this},lookup:function(){var items;return this.query=this.$element.val(),!this.query||this.query.length"+match+""})},render:function(items){var that=this;return items=$(items).map(function(i,item){return i=$(that.options.item).attr("data-value",item),i.find("a").html(that.highlighter(item)),i[0]}),items.first().addClass("active"),this.$menu.html(items),this},next:function(){var active=this.$menu.find(".active").removeClass("active"),next=active.next();next.length||(next=$(this.$menu.find("li")[0])),next.addClass("active")},prev:function(){var active=this.$menu.find(".active").removeClass("active"),prev=active.prev();prev.length||(prev=this.$menu.find("li").last()),prev.addClass("active")},listen:function(){this.$element.on("blur",$.proxy(this.blur,this)).on("keypress",$.proxy(this.keypress,this)).on("keyup",$.proxy(this.keyup,this)),this.eventSupported("keydown")&&this.$element.on("keydown",$.proxy(this.keydown,this)),this.$menu.on("click",$.proxy(this.click,this)).on("mouseenter","li",$.proxy(this.mouseenter,this))},eventSupported:function(eventName){var isSupported=eventName in this.$element;return isSupported||(this.$element.setAttribute(eventName,"return;"),isSupported="function"==typeof this.$element[eventName]),isSupported},move:function(e){if(this.shown){switch(e.keyCode){case 9:case 13:case 27:e.preventDefault();break;case 38:e.preventDefault(),this.prev();break;case 40:e.preventDefault(),this.next()}e.stopPropagation()}},keydown:function(e){this.suppressKeyPressRepeat=~$.inArray(e.keyCode,[40,38,9,13,27]),this.move(e)},keypress:function(e){this.suppressKeyPressRepeat||this.move(e)},keyup:function(e){switch(e.keyCode){case 40:case 38:case 16:case 17:case 18:break;case 9:case 13:if(!this.shown)return;this.select();break;case 27:if(!this.shown)return;this.hide();break;default:this.lookup()}e.stopPropagation(),e.preventDefault()},blur:function(){var that=this;setTimeout(function(){that.hide()},150)},click:function(e){e.stopPropagation(),e.preventDefault(),this.select()},mouseenter:function(e){this.$menu.find(".active").removeClass("active"),$(e.currentTarget).addClass("active")}};var old=$.fn.typeahead;$.fn.typeahead=function(option){return this.each(function(){var $this=$(this),data=$this.data("typeahead"),options="object"==typeof option&&option;data||$this.data("typeahead",data=new Typeahead(this,options)),"string"==typeof option&&data[option]()})},$.fn.typeahead.defaults={source:[],items:8,menu:'
      ',item:'
      • ',minLength:1},$.fn.typeahead.Constructor=Typeahead,$.fn.typeahead.noConflict=function(){return $.fn.typeahead=old,this},$(document).on("focus.typeahead.data-api",'[data-provide="typeahead"]',function(e){var $this=$(this);$this.data("typeahead")||(e.preventDefault(),$this.typeahead($this.data()))})}(window.jQuery),!function($){"use strict";var Affix=function(element,options){this.options=$.extend({},$.fn.affix.defaults,options),this.$window=$(window).on("scroll.affix.data-api",$.proxy(this.checkPosition,this)).on("click.affix.data-api",$.proxy(function(){setTimeout($.proxy(this.checkPosition,this),1)},this)),this.$element=$(element),this.checkPosition()};Affix.prototype.checkPosition=function(){if(this.$element.is(":visible")){var affix,scrollHeight=$(document).height(),scrollTop=this.$window.scrollTop(),position=this.$element.offset(),offset=this.options.offset,offsetBottom=offset.bottom,offsetTop=offset.top,reset="affix affix-top affix-bottom";"object"!=typeof offset&&(offsetBottom=offsetTop=offset),"function"==typeof offsetTop&&(offsetTop=offset.top()),"function"==typeof offsetBottom&&(offsetBottom=offset.bottom()),affix=null!=this.unpin&&scrollTop+this.unpin<=position.top?!1:null!=offsetBottom&&position.top+this.$element.height()>=scrollHeight-offsetBottom?"bottom":null!=offsetTop&&offsetTop>=scrollTop?"top":!1,this.affixed!==affix&&(this.affixed=affix,this.unpin="bottom"==affix?position.top-scrollTop:null,this.$element.removeClass(reset).addClass("affix"+(affix?"-"+affix:"")))}};var old=$.fn.affix;$.fn.affix=function(option){return this.each(function(){var $this=$(this),data=$this.data("affix"),options="object"==typeof option&&option;data||$this.data("affix",data=new Affix(this,options)),"string"==typeof option&&data[option]()})},$.fn.affix.Constructor=Affix,$.fn.affix.defaults={offset:0},$.fn.affix.noConflict=function(){return $.fn.affix=old,this},$(window).on("load",function(){$('[data-spy="affix"]').each(function(){var $spy=$(this),data=$spy.data();data.offset=data.offset||{},data.offsetBottom&&(data.offset.bottom=data.offsetBottom),data.offsetTop&&(data.offset.top=data.offsetTop),$spy.affix(data)})})}(window.jQuery); \ No newline at end of file diff --git a/website/js/jquery.js b/website/js/jquery.js new file mode 100644 index 00000000..45477c0b --- /dev/null +++ b/website/js/jquery.js @@ -0,0 +1,2 @@ +/*! jQuery v1.8.3 jquery.com | jquery.org/license */ +(function(e,t){function _(e){var t=M[e]={};return v.each(e.split(y),function(e,n){t[n]=!0}),t}function H(e,n,r){if(r===t&&e.nodeType===1){var i="data-"+n.replace(P,"-$1").toLowerCase();r=e.getAttribute(i);if(typeof r=="string"){try{r=r==="true"?!0:r==="false"?!1:r==="null"?null:+r+""===r?+r:D.test(r)?v.parseJSON(r):r}catch(s){}v.data(e,n,r)}else r=t}return r}function B(e){var t;for(t in e){if(t==="data"&&v.isEmptyObject(e[t]))continue;if(t!=="toJSON")return!1}return!0}function et(){return!1}function tt(){return!0}function ut(e){return!e||!e.parentNode||e.parentNode.nodeType===11}function at(e,t){do e=e[t];while(e&&e.nodeType!==1);return e}function ft(e,t,n){t=t||0;if(v.isFunction(t))return v.grep(e,function(e,r){var i=!!t.call(e,r,e);return i===n});if(t.nodeType)return v.grep(e,function(e,r){return e===t===n});if(typeof t=="string"){var r=v.grep(e,function(e){return e.nodeType===1});if(it.test(t))return v.filter(t,r,!n);t=v.filter(t,r)}return v.grep(e,function(e,r){return v.inArray(e,t)>=0===n})}function lt(e){var t=ct.split("|"),n=e.createDocumentFragment();if(n.createElement)while(t.length)n.createElement(t.pop());return n}function Lt(e,t){return e.getElementsByTagName(t)[0]||e.appendChild(e.ownerDocument.createElement(t))}function At(e,t){if(t.nodeType!==1||!v.hasData(e))return;var n,r,i,s=v._data(e),o=v._data(t,s),u=s.events;if(u){delete o.handle,o.events={};for(n in u)for(r=0,i=u[n].length;r").appendTo(i.body),n=t.css("display");t.remove();if(n==="none"||n===""){Pt=i.body.appendChild(Pt||v.extend(i.createElement("iframe"),{frameBorder:0,width:0,height:0}));if(!Ht||!Pt.createElement)Ht=(Pt.contentWindow||Pt.contentDocument).document,Ht.write(""),Ht.close();t=Ht.body.appendChild(Ht.createElement(e)),n=Dt(t,"display"),i.body.removeChild(Pt)}return Wt[e]=n,n}function fn(e,t,n,r){var i;if(v.isArray(t))v.each(t,function(t,i){n||sn.test(e)?r(e,i):fn(e+"["+(typeof i=="object"?t:"")+"]",i,n,r)});else if(!n&&v.type(t)==="object")for(i in t)fn(e+"["+i+"]",t[i],n,r);else r(e,t)}function Cn(e){return function(t,n){typeof t!="string"&&(n=t,t="*");var r,i,s,o=t.toLowerCase().split(y),u=0,a=o.length;if(v.isFunction(n))for(;u)[^>]*$|#([\w\-]*)$)/,E=/^<(\w+)\s*\/?>(?:<\/\1>|)$/,S=/^[\],:{}\s]*$/,x=/(?:^|:|,)(?:\s*\[)+/g,T=/\\(?:["\\\/bfnrt]|u[\da-fA-F]{4})/g,N=/"[^"\\\r\n]*"|true|false|null|-?(?:\d\d*\.|)\d+(?:[eE][\-+]?\d+|)/g,C=/^-ms-/,k=/-([\da-z])/gi,L=function(e,t){return(t+"").toUpperCase()},A=function(){i.addEventListener?(i.removeEventListener("DOMContentLoaded",A,!1),v.ready()):i.readyState==="complete"&&(i.detachEvent("onreadystatechange",A),v.ready())},O={};v.fn=v.prototype={constructor:v,init:function(e,n,r){var s,o,u,a;if(!e)return this;if(e.nodeType)return this.context=this[0]=e,this.length=1,this;if(typeof e=="string"){e.charAt(0)==="<"&&e.charAt(e.length-1)===">"&&e.length>=3?s=[null,e,null]:s=w.exec(e);if(s&&(s[1]||!n)){if(s[1])return n=n instanceof v?n[0]:n,a=n&&n.nodeType?n.ownerDocument||n:i,e=v.parseHTML(s[1],a,!0),E.test(s[1])&&v.isPlainObject(n)&&this.attr.call(e,n,!0),v.merge(this,e);o=i.getElementById(s[2]);if(o&&o.parentNode){if(o.id!==s[2])return r.find(e);this.length=1,this[0]=o}return this.context=i,this.selector=e,this}return!n||n.jquery?(n||r).find(e):this.constructor(n).find(e)}return v.isFunction(e)?r.ready(e):(e.selector!==t&&(this.selector=e.selector,this.context=e.context),v.makeArray(e,this))},selector:"",jquery:"1.8.3",length:0,size:function(){return this.length},toArray:function(){return l.call(this)},get:function(e){return e==null?this.toArray():e<0?this[this.length+e]:this[e]},pushStack:function(e,t,n){var r=v.merge(this.constructor(),e);return r.prevObject=this,r.context=this.context,t==="find"?r.selector=this.selector+(this.selector?" ":"")+n:t&&(r.selector=this.selector+"."+t+"("+n+")"),r},each:function(e,t){return v.each(this,e,t)},ready:function(e){return v.ready.promise().done(e),this},eq:function(e){return e=+e,e===-1?this.slice(e):this.slice(e,e+1)},first:function(){return this.eq(0)},last:function(){return this.eq(-1)},slice:function(){return this.pushStack(l.apply(this,arguments),"slice",l.call(arguments).join(","))},map:function(e){return this.pushStack(v.map(this,function(t,n){return e.call(t,n,t)}))},end:function(){return this.prevObject||this.constructor(null)},push:f,sort:[].sort,splice:[].splice},v.fn.init.prototype=v.fn,v.extend=v.fn.extend=function(){var e,n,r,i,s,o,u=arguments[0]||{},a=1,f=arguments.length,l=!1;typeof u=="boolean"&&(l=u,u=arguments[1]||{},a=2),typeof u!="object"&&!v.isFunction(u)&&(u={}),f===a&&(u=this,--a);for(;a0)return;r.resolveWith(i,[v]),v.fn.trigger&&v(i).trigger("ready").off("ready")},isFunction:function(e){return v.type(e)==="function"},isArray:Array.isArray||function(e){return v.type(e)==="array"},isWindow:function(e){return e!=null&&e==e.window},isNumeric:function(e){return!isNaN(parseFloat(e))&&isFinite(e)},type:function(e){return e==null?String(e):O[h.call(e)]||"object"},isPlainObject:function(e){if(!e||v.type(e)!=="object"||e.nodeType||v.isWindow(e))return!1;try{if(e.constructor&&!p.call(e,"constructor")&&!p.call(e.constructor.prototype,"isPrototypeOf"))return!1}catch(n){return!1}var r;for(r in e);return r===t||p.call(e,r)},isEmptyObject:function(e){var t;for(t in e)return!1;return!0},error:function(e){throw new Error(e)},parseHTML:function(e,t,n){var r;return!e||typeof e!="string"?null:(typeof t=="boolean"&&(n=t,t=0),t=t||i,(r=E.exec(e))?[t.createElement(r[1])]:(r=v.buildFragment([e],t,n?null:[]),v.merge([],(r.cacheable?v.clone(r.fragment):r.fragment).childNodes)))},parseJSON:function(t){if(!t||typeof t!="string")return null;t=v.trim(t);if(e.JSON&&e.JSON.parse)return e.JSON.parse(t);if(S.test(t.replace(T,"@").replace(N,"]").replace(x,"")))return(new Function("return "+t))();v.error("Invalid JSON: "+t)},parseXML:function(n){var r,i;if(!n||typeof n!="string")return null;try{e.DOMParser?(i=new DOMParser,r=i.parseFromString(n,"text/xml")):(r=new ActiveXObject("Microsoft.XMLDOM"),r.async="false",r.loadXML(n))}catch(s){r=t}return(!r||!r.documentElement||r.getElementsByTagName("parsererror").length)&&v.error("Invalid XML: "+n),r},noop:function(){},globalEval:function(t){t&&g.test(t)&&(e.execScript||function(t){e.eval.call(e,t)})(t)},camelCase:function(e){return e.replace(C,"ms-").replace(k,L)},nodeName:function(e,t){return e.nodeName&&e.nodeName.toLowerCase()===t.toLowerCase()},each:function(e,n,r){var i,s=0,o=e.length,u=o===t||v.isFunction(e);if(r){if(u){for(i in e)if(n.apply(e[i],r)===!1)break}else for(;s0&&e[0]&&e[a-1]||a===0||v.isArray(e));if(f)for(;u-1)a.splice(n,1),i&&(n<=o&&o--,n<=u&&u--)}),this},has:function(e){return v.inArray(e,a)>-1},empty:function(){return a=[],this},disable:function(){return a=f=n=t,this},disabled:function(){return!a},lock:function(){return f=t,n||c.disable(),this},locked:function(){return!f},fireWith:function(e,t){return t=t||[],t=[e,t.slice?t.slice():t],a&&(!r||f)&&(i?f.push(t):l(t)),this},fire:function(){return c.fireWith(this,arguments),this},fired:function(){return!!r}};return c},v.extend({Deferred:function(e){var t=[["resolve","done",v.Callbacks("once memory"),"resolved"],["reject","fail",v.Callbacks("once memory"),"rejected"],["notify","progress",v.Callbacks("memory")]],n="pending",r={state:function(){return n},always:function(){return i.done(arguments).fail(arguments),this},then:function(){var e=arguments;return v.Deferred(function(n){v.each(t,function(t,r){var s=r[0],o=e[t];i[r[1]](v.isFunction(o)?function(){var e=o.apply(this,arguments);e&&v.isFunction(e.promise)?e.promise().done(n.resolve).fail(n.reject).progress(n.notify):n[s+"With"](this===i?n:this,[e])}:n[s])}),e=null}).promise()},promise:function(e){return e!=null?v.extend(e,r):r}},i={};return r.pipe=r.then,v.each(t,function(e,s){var o=s[2],u=s[3];r[s[1]]=o.add,u&&o.add(function(){n=u},t[e^1][2].disable,t[2][2].lock),i[s[0]]=o.fire,i[s[0]+"With"]=o.fireWith}),r.promise(i),e&&e.call(i,i),i},when:function(e){var t=0,n=l.call(arguments),r=n.length,i=r!==1||e&&v.isFunction(e.promise)?r:0,s=i===1?e:v.Deferred(),o=function(e,t,n){return function(r){t[e]=this,n[e]=arguments.length>1?l.call(arguments):r,n===u?s.notifyWith(t,n):--i||s.resolveWith(t,n)}},u,a,f;if(r>1){u=new Array(r),a=new Array(r),f=new Array(r);for(;t
      a",n=p.getElementsByTagName("*"),r=p.getElementsByTagName("a")[0];if(!n||!r||!n.length)return{};s=i.createElement("select"),o=s.appendChild(i.createElement("option")),u=p.getElementsByTagName("input")[0],r.style.cssText="top:1px;float:left;opacity:.5",t={leadingWhitespace:p.firstChild.nodeType===3,tbody:!p.getElementsByTagName("tbody").length,htmlSerialize:!!p.getElementsByTagName("link").length,style:/top/.test(r.getAttribute("style")),hrefNormalized:r.getAttribute("href")==="/a",opacity:/^0.5/.test(r.style.opacity),cssFloat:!!r.style.cssFloat,checkOn:u.value==="on",optSelected:o.selected,getSetAttribute:p.className!=="t",enctype:!!i.createElement("form").enctype,html5Clone:i.createElement("nav").cloneNode(!0).outerHTML!=="<:nav>",boxModel:i.compatMode==="CSS1Compat",submitBubbles:!0,changeBubbles:!0,focusinBubbles:!1,deleteExpando:!0,noCloneEvent:!0,inlineBlockNeedsLayout:!1,shrinkWrapBlocks:!1,reliableMarginRight:!0,boxSizingReliable:!0,pixelPosition:!1},u.checked=!0,t.noCloneChecked=u.cloneNode(!0).checked,s.disabled=!0,t.optDisabled=!o.disabled;try{delete p.test}catch(d){t.deleteExpando=!1}!p.addEventListener&&p.attachEvent&&p.fireEvent&&(p.attachEvent("onclick",h=function(){t.noCloneEvent=!1}),p.cloneNode(!0).fireEvent("onclick"),p.detachEvent("onclick",h)),u=i.createElement("input"),u.value="t",u.setAttribute("type","radio"),t.radioValue=u.value==="t",u.setAttribute("checked","checked"),u.setAttribute("name","t"),p.appendChild(u),a=i.createDocumentFragment(),a.appendChild(p.lastChild),t.checkClone=a.cloneNode(!0).cloneNode(!0).lastChild.checked,t.appendChecked=u.checked,a.removeChild(u),a.appendChild(p);if(p.attachEvent)for(l in{submit:!0,change:!0,focusin:!0})f="on"+l,c=f in p,c||(p.setAttribute(f,"return;"),c=typeof p[f]=="function"),t[l+"Bubbles"]=c;return v(function(){var n,r,s,o,u="padding:0;margin:0;border:0;display:block;overflow:hidden;",a=i.getElementsByTagName("body")[0];if(!a)return;n=i.createElement("div"),n.style.cssText="visibility:hidden;border:0;width:0;height:0;position:static;top:0;margin-top:1px",a.insertBefore(n,a.firstChild),r=i.createElement("div"),n.appendChild(r),r.innerHTML="
      t
      ",s=r.getElementsByTagName("td"),s[0].style.cssText="padding:0;margin:0;border:0;display:none",c=s[0].offsetHeight===0,s[0].style.display="",s[1].style.display="none",t.reliableHiddenOffsets=c&&s[0].offsetHeight===0,r.innerHTML="",r.style.cssText="box-sizing:border-box;-moz-box-sizing:border-box;-webkit-box-sizing:border-box;padding:1px;border:1px;display:block;width:4px;margin-top:1%;position:absolute;top:1%;",t.boxSizing=r.offsetWidth===4,t.doesNotIncludeMarginInBodyOffset=a.offsetTop!==1,e.getComputedStyle&&(t.pixelPosition=(e.getComputedStyle(r,null)||{}).top!=="1%",t.boxSizingReliable=(e.getComputedStyle(r,null)||{width:"4px"}).width==="4px",o=i.createElement("div"),o.style.cssText=r.style.cssText=u,o.style.marginRight=o.style.width="0",r.style.width="1px",r.appendChild(o),t.reliableMarginRight=!parseFloat((e.getComputedStyle(o,null)||{}).marginRight)),typeof r.style.zoom!="undefined"&&(r.innerHTML="",r.style.cssText=u+"width:1px;padding:1px;display:inline;zoom:1",t.inlineBlockNeedsLayout=r.offsetWidth===3,r.style.display="block",r.style.overflow="visible",r.innerHTML="
      ",r.firstChild.style.width="5px",t.shrinkWrapBlocks=r.offsetWidth!==3,n.style.zoom=1),a.removeChild(n),n=r=s=o=null}),a.removeChild(p),n=r=s=o=u=a=p=null,t}();var D=/(?:\{[\s\S]*\}|\[[\s\S]*\])$/,P=/([A-Z])/g;v.extend({cache:{},deletedIds:[],uuid:0,expando:"jQuery"+(v.fn.jquery+Math.random()).replace(/\D/g,""),noData:{embed:!0,object:"clsid:D27CDB6E-AE6D-11cf-96B8-444553540000",applet:!0},hasData:function(e){return e=e.nodeType?v.cache[e[v.expando]]:e[v.expando],!!e&&!B(e)},data:function(e,n,r,i){if(!v.acceptData(e))return;var s,o,u=v.expando,a=typeof n=="string",f=e.nodeType,l=f?v.cache:e,c=f?e[u]:e[u]&&u;if((!c||!l[c]||!i&&!l[c].data)&&a&&r===t)return;c||(f?e[u]=c=v.deletedIds.pop()||v.guid++:c=u),l[c]||(l[c]={},f||(l[c].toJSON=v.noop));if(typeof n=="object"||typeof n=="function")i?l[c]=v.extend(l[c],n):l[c].data=v.extend(l[c].data,n);return s=l[c],i||(s.data||(s.data={}),s=s.data),r!==t&&(s[v.camelCase(n)]=r),a?(o=s[n],o==null&&(o=s[v.camelCase(n)])):o=s,o},removeData:function(e,t,n){if(!v.acceptData(e))return;var r,i,s,o=e.nodeType,u=o?v.cache:e,a=o?e[v.expando]:v.expando;if(!u[a])return;if(t){r=n?u[a]:u[a].data;if(r){v.isArray(t)||(t in r?t=[t]:(t=v.camelCase(t),t in r?t=[t]:t=t.split(" ")));for(i=0,s=t.length;i1,null,!1))},removeData:function(e){return this.each(function(){v.removeData(this,e)})}}),v.extend({queue:function(e,t,n){var r;if(e)return t=(t||"fx")+"queue",r=v._data(e,t),n&&(!r||v.isArray(n)?r=v._data(e,t,v.makeArray(n)):r.push(n)),r||[]},dequeue:function(e,t){t=t||"fx";var n=v.queue(e,t),r=n.length,i=n.shift(),s=v._queueHooks(e,t),o=function(){v.dequeue(e,t)};i==="inprogress"&&(i=n.shift(),r--),i&&(t==="fx"&&n.unshift("inprogress"),delete s.stop,i.call(e,o,s)),!r&&s&&s.empty.fire()},_queueHooks:function(e,t){var n=t+"queueHooks";return v._data(e,n)||v._data(e,n,{empty:v.Callbacks("once memory").add(function(){v.removeData(e,t+"queue",!0),v.removeData(e,n,!0)})})}}),v.fn.extend({queue:function(e,n){var r=2;return typeof e!="string"&&(n=e,e="fx",r--),arguments.length1)},removeAttr:function(e){return this.each(function(){v.removeAttr(this,e)})},prop:function(e,t){return v.access(this,v.prop,e,t,arguments.length>1)},removeProp:function(e){return e=v.propFix[e]||e,this.each(function(){try{this[e]=t,delete this[e]}catch(n){}})},addClass:function(e){var t,n,r,i,s,o,u;if(v.isFunction(e))return this.each(function(t){v(this).addClass(e.call(this,t,this.className))});if(e&&typeof e=="string"){t=e.split(y);for(n=0,r=this.length;n=0)r=r.replace(" "+n[s]+" "," ");i.className=e?v.trim(r):""}}}return this},toggleClass:function(e,t){var n=typeof e,r=typeof t=="boolean";return v.isFunction(e)?this.each(function(n){v(this).toggleClass(e.call(this,n,this.className,t),t)}):this.each(function(){if(n==="string"){var i,s=0,o=v(this),u=t,a=e.split(y);while(i=a[s++])u=r?u:!o.hasClass(i),o[u?"addClass":"removeClass"](i)}else if(n==="undefined"||n==="boolean")this.className&&v._data(this,"__className__",this.className),this.className=this.className||e===!1?"":v._data(this,"__className__")||""})},hasClass:function(e){var t=" "+e+" ",n=0,r=this.length;for(;n=0)return!0;return!1},val:function(e){var n,r,i,s=this[0];if(!arguments.length){if(s)return n=v.valHooks[s.type]||v.valHooks[s.nodeName.toLowerCase()],n&&"get"in n&&(r=n.get(s,"value"))!==t?r:(r=s.value,typeof r=="string"?r.replace(R,""):r==null?"":r);return}return i=v.isFunction(e),this.each(function(r){var s,o=v(this);if(this.nodeType!==1)return;i?s=e.call(this,r,o.val()):s=e,s==null?s="":typeof s=="number"?s+="":v.isArray(s)&&(s=v.map(s,function(e){return e==null?"":e+""})),n=v.valHooks[this.type]||v.valHooks[this.nodeName.toLowerCase()];if(!n||!("set"in n)||n.set(this,s,"value")===t)this.value=s})}}),v.extend({valHooks:{option:{get:function(e){var t=e.attributes.value;return!t||t.specified?e.value:e.text}},select:{get:function(e){var t,n,r=e.options,i=e.selectedIndex,s=e.type==="select-one"||i<0,o=s?null:[],u=s?i+1:r.length,a=i<0?u:s?i:0;for(;a=0}),n.length||(e.selectedIndex=-1),n}}},attrFn:{},attr:function(e,n,r,i){var s,o,u,a=e.nodeType;if(!e||a===3||a===8||a===2)return;if(i&&v.isFunction(v.fn[n]))return v(e)[n](r);if(typeof e.getAttribute=="undefined")return v.prop(e,n,r);u=a!==1||!v.isXMLDoc(e),u&&(n=n.toLowerCase(),o=v.attrHooks[n]||(X.test(n)?F:j));if(r!==t){if(r===null){v.removeAttr(e,n);return}return o&&"set"in o&&u&&(s=o.set(e,r,n))!==t?s:(e.setAttribute(n,r+""),r)}return o&&"get"in o&&u&&(s=o.get(e,n))!==null?s:(s=e.getAttribute(n),s===null?t:s)},removeAttr:function(e,t){var n,r,i,s,o=0;if(t&&e.nodeType===1){r=t.split(y);for(;o=0}})});var $=/^(?:textarea|input|select)$/i,J=/^([^\.]*|)(?:\.(.+)|)$/,K=/(?:^|\s)hover(\.\S+|)\b/,Q=/^key/,G=/^(?:mouse|contextmenu)|click/,Y=/^(?:focusinfocus|focusoutblur)$/,Z=function(e){return v.event.special.hover?e:e.replace(K,"mouseenter$1 mouseleave$1")};v.event={add:function(e,n,r,i,s){var o,u,a,f,l,c,h,p,d,m,g;if(e.nodeType===3||e.nodeType===8||!n||!r||!(o=v._data(e)))return;r.handler&&(d=r,r=d.handler,s=d.selector),r.guid||(r.guid=v.guid++),a=o.events,a||(o.events=a={}),u=o.handle,u||(o.handle=u=function(e){return typeof v=="undefined"||!!e&&v.event.triggered===e.type?t:v.event.dispatch.apply(u.elem,arguments)},u.elem=e),n=v.trim(Z(n)).split(" ");for(f=0;f=0&&(y=y.slice(0,-1),a=!0),y.indexOf(".")>=0&&(b=y.split("."),y=b.shift(),b.sort());if((!s||v.event.customEvent[y])&&!v.event.global[y])return;n=typeof n=="object"?n[v.expando]?n:new v.Event(y,n):new v.Event(y),n.type=y,n.isTrigger=!0,n.exclusive=a,n.namespace=b.join("."),n.namespace_re=n.namespace?new RegExp("(^|\\.)"+b.join("\\.(?:.*\\.|)")+"(\\.|$)"):null,h=y.indexOf(":")<0?"on"+y:"";if(!s){u=v.cache;for(f in u)u[f].events&&u[f].events[y]&&v.event.trigger(n,r,u[f].handle.elem,!0);return}n.result=t,n.target||(n.target=s),r=r!=null?v.makeArray(r):[],r.unshift(n),p=v.event.special[y]||{};if(p.trigger&&p.trigger.apply(s,r)===!1)return;m=[[s,p.bindType||y]];if(!o&&!p.noBubble&&!v.isWindow(s)){g=p.delegateType||y,l=Y.test(g+y)?s:s.parentNode;for(c=s;l;l=l.parentNode)m.push([l,g]),c=l;c===(s.ownerDocument||i)&&m.push([c.defaultView||c.parentWindow||e,g])}for(f=0;f=0:v.find(h,this,null,[s]).length),u[h]&&f.push(c);f.length&&w.push({elem:s,matches:f})}d.length>m&&w.push({elem:this,matches:d.slice(m)});for(r=0;r0?this.on(t,null,e,n):this.trigger(t)},Q.test(t)&&(v.event.fixHooks[t]=v.event.keyHooks),G.test(t)&&(v.event.fixHooks[t]=v.event.mouseHooks)}),function(e,t){function nt(e,t,n,r){n=n||[],t=t||g;var i,s,a,f,l=t.nodeType;if(!e||typeof e!="string")return n;if(l!==1&&l!==9)return[];a=o(t);if(!a&&!r)if(i=R.exec(e))if(f=i[1]){if(l===9){s=t.getElementById(f);if(!s||!s.parentNode)return n;if(s.id===f)return n.push(s),n}else if(t.ownerDocument&&(s=t.ownerDocument.getElementById(f))&&u(t,s)&&s.id===f)return n.push(s),n}else{if(i[2])return S.apply(n,x.call(t.getElementsByTagName(e),0)),n;if((f=i[3])&&Z&&t.getElementsByClassName)return S.apply(n,x.call(t.getElementsByClassName(f),0)),n}return vt(e.replace(j,"$1"),t,n,r,a)}function rt(e){return function(t){var n=t.nodeName.toLowerCase();return n==="input"&&t.type===e}}function it(e){return function(t){var n=t.nodeName.toLowerCase();return(n==="input"||n==="button")&&t.type===e}}function st(e){return N(function(t){return t=+t,N(function(n,r){var i,s=e([],n.length,t),o=s.length;while(o--)n[i=s[o]]&&(n[i]=!(r[i]=n[i]))})})}function ot(e,t,n){if(e===t)return n;var r=e.nextSibling;while(r){if(r===t)return-1;r=r.nextSibling}return 1}function ut(e,t){var n,r,s,o,u,a,f,l=L[d][e+" "];if(l)return t?0:l.slice(0);u=e,a=[],f=i.preFilter;while(u){if(!n||(r=F.exec(u)))r&&(u=u.slice(r[0].length)||u),a.push(s=[]);n=!1;if(r=I.exec(u))s.push(n=new m(r.shift())),u=u.slice(n.length),n.type=r[0].replace(j," ");for(o in i.filter)(r=J[o].exec(u))&&(!f[o]||(r=f[o](r)))&&(s.push(n=new m(r.shift())),u=u.slice(n.length),n.type=o,n.matches=r);if(!n)break}return t?u.length:u?nt.error(e):L(e,a).slice(0)}function at(e,t,r){var i=t.dir,s=r&&t.dir==="parentNode",o=w++;return t.first?function(t,n,r){while(t=t[i])if(s||t.nodeType===1)return e(t,n,r)}:function(t,r,u){if(!u){var a,f=b+" "+o+" ",l=f+n;while(t=t[i])if(s||t.nodeType===1){if((a=t[d])===l)return t.sizset;if(typeof a=="string"&&a.indexOf(f)===0){if(t.sizset)return t}else{t[d]=l;if(e(t,r,u))return t.sizset=!0,t;t.sizset=!1}}}else while(t=t[i])if(s||t.nodeType===1)if(e(t,r,u))return t}}function ft(e){return e.length>1?function(t,n,r){var i=e.length;while(i--)if(!e[i](t,n,r))return!1;return!0}:e[0]}function lt(e,t,n,r,i){var s,o=[],u=0,a=e.length,f=t!=null;for(;u-1&&(s[f]=!(o[f]=c))}}else g=lt(g===o?g.splice(d,g.length):g),i?i(null,o,g,a):S.apply(o,g)})}function ht(e){var t,n,r,s=e.length,o=i.relative[e[0].type],u=o||i.relative[" "],a=o?1:0,f=at(function(e){return e===t},u,!0),l=at(function(e){return T.call(t,e)>-1},u,!0),h=[function(e,n,r){return!o&&(r||n!==c)||((t=n).nodeType?f(e,n,r):l(e,n,r))}];for(;a1&&ft(h),a>1&&e.slice(0,a-1).join("").replace(j,"$1"),n,a0,s=e.length>0,o=function(u,a,f,l,h){var p,d,v,m=[],y=0,w="0",x=u&&[],T=h!=null,N=c,C=u||s&&i.find.TAG("*",h&&a.parentNode||a),k=b+=N==null?1:Math.E;T&&(c=a!==g&&a,n=o.el);for(;(p=C[w])!=null;w++){if(s&&p){for(d=0;v=e[d];d++)if(v(p,a,f)){l.push(p);break}T&&(b=k,n=++o.el)}r&&((p=!v&&p)&&y--,u&&x.push(p))}y+=w;if(r&&w!==y){for(d=0;v=t[d];d++)v(x,m,a,f);if(u){if(y>0)while(w--)!x[w]&&!m[w]&&(m[w]=E.call(l));m=lt(m)}S.apply(l,m),T&&!u&&m.length>0&&y+t.length>1&&nt.uniqueSort(l)}return T&&(b=k,c=N),x};return o.el=0,r?N(o):o}function dt(e,t,n){var r=0,i=t.length;for(;r2&&(f=u[0]).type==="ID"&&t.nodeType===9&&!s&&i.relative[u[1].type]){t=i.find.ID(f.matches[0].replace($,""),t,s)[0];if(!t)return n;e=e.slice(u.shift().length)}for(o=J.POS.test(e)?-1:u.length-1;o>=0;o--){f=u[o];if(i.relative[l=f.type])break;if(c=i.find[l])if(r=c(f.matches[0].replace($,""),z.test(u[0].type)&&t.parentNode||t,s)){u.splice(o,1),e=r.length&&u.join("");if(!e)return S.apply(n,x.call(r,0)),n;break}}}return a(e,h)(r,t,s,n,z.test(e)),n}function mt(){}var n,r,i,s,o,u,a,f,l,c,h=!0,p="undefined",d=("sizcache"+Math.random()).replace(".",""),m=String,g=e.document,y=g.documentElement,b=0,w=0,E=[].pop,S=[].push,x=[].slice,T=[].indexOf||function(e){var t=0,n=this.length;for(;ti.cacheLength&&delete e[t.shift()],e[n+" "]=r},e)},k=C(),L=C(),A=C(),O="[\\x20\\t\\r\\n\\f]",M="(?:\\\\.|[-\\w]|[^\\x00-\\xa0])+",_=M.replace("w","w#"),D="([*^$|!~]?=)",P="\\["+O+"*("+M+")"+O+"*(?:"+D+O+"*(?:(['\"])((?:\\\\.|[^\\\\])*?)\\3|("+_+")|)|)"+O+"*\\]",H=":("+M+")(?:\\((?:(['\"])((?:\\\\.|[^\\\\])*?)\\2|([^()[\\]]*|(?:(?:"+P+")|[^:]|\\\\.)*|.*))\\)|)",B=":(even|odd|eq|gt|lt|nth|first|last)(?:\\("+O+"*((?:-\\d)?\\d*)"+O+"*\\)|)(?=[^-]|$)",j=new RegExp("^"+O+"+|((?:^|[^\\\\])(?:\\\\.)*)"+O+"+$","g"),F=new RegExp("^"+O+"*,"+O+"*"),I=new RegExp("^"+O+"*([\\x20\\t\\r\\n\\f>+~])"+O+"*"),q=new RegExp(H),R=/^(?:#([\w\-]+)|(\w+)|\.([\w\-]+))$/,U=/^:not/,z=/[\x20\t\r\n\f]*[+~]/,W=/:not\($/,X=/h\d/i,V=/input|select|textarea|button/i,$=/\\(?!\\)/g,J={ID:new RegExp("^#("+M+")"),CLASS:new RegExp("^\\.("+M+")"),NAME:new RegExp("^\\[name=['\"]?("+M+")['\"]?\\]"),TAG:new RegExp("^("+M.replace("w","w*")+")"),ATTR:new RegExp("^"+P),PSEUDO:new RegExp("^"+H),POS:new RegExp(B,"i"),CHILD:new RegExp("^:(only|nth|first|last)-child(?:\\("+O+"*(even|odd|(([+-]|)(\\d*)n|)"+O+"*(?:([+-]|)"+O+"*(\\d+)|))"+O+"*\\)|)","i"),needsContext:new RegExp("^"+O+"*[>+~]|"+B,"i")},K=function(e){var t=g.createElement("div");try{return e(t)}catch(n){return!1}finally{t=null}},Q=K(function(e){return e.appendChild(g.createComment("")),!e.getElementsByTagName("*").length}),G=K(function(e){return e.innerHTML="",e.firstChild&&typeof e.firstChild.getAttribute!==p&&e.firstChild.getAttribute("href")==="#"}),Y=K(function(e){e.innerHTML="";var t=typeof e.lastChild.getAttribute("multiple");return t!=="boolean"&&t!=="string"}),Z=K(function(e){return e.innerHTML="",!e.getElementsByClassName||!e.getElementsByClassName("e").length?!1:(e.lastChild.className="e",e.getElementsByClassName("e").length===2)}),et=K(function(e){e.id=d+0,e.innerHTML="
      ",y.insertBefore(e,y.firstChild);var t=g.getElementsByName&&g.getElementsByName(d).length===2+g.getElementsByName(d+0).length;return r=!g.getElementById(d),y.removeChild(e),t});try{x.call(y.childNodes,0)[0].nodeType}catch(tt){x=function(e){var t,n=[];for(;t=this[e];e++)n.push(t);return n}}nt.matches=function(e,t){return nt(e,null,null,t)},nt.matchesSelector=function(e,t){return nt(t,null,null,[e]).length>0},s=nt.getText=function(e){var t,n="",r=0,i=e.nodeType;if(i){if(i===1||i===9||i===11){if(typeof e.textContent=="string")return e.textContent;for(e=e.firstChild;e;e=e.nextSibling)n+=s(e)}else if(i===3||i===4)return e.nodeValue}else for(;t=e[r];r++)n+=s(t);return n},o=nt.isXML=function(e){var t=e&&(e.ownerDocument||e).documentElement;return t?t.nodeName!=="HTML":!1},u=nt.contains=y.contains?function(e,t){var n=e.nodeType===9?e.documentElement:e,r=t&&t.parentNode;return e===r||!!(r&&r.nodeType===1&&n.contains&&n.contains(r))}:y.compareDocumentPosition?function(e,t){return t&&!!(e.compareDocumentPosition(t)&16)}:function(e,t){while(t=t.parentNode)if(t===e)return!0;return!1},nt.attr=function(e,t){var n,r=o(e);return r||(t=t.toLowerCase()),(n=i.attrHandle[t])?n(e):r||Y?e.getAttribute(t):(n=e.getAttributeNode(t),n?typeof e[t]=="boolean"?e[t]?t:null:n.specified?n.value:null:null)},i=nt.selectors={cacheLength:50,createPseudo:N,match:J,attrHandle:G?{}:{href:function(e){return e.getAttribute("href",2)},type:function(e){return e.getAttribute("type")}},find:{ID:r?function(e,t,n){if(typeof t.getElementById!==p&&!n){var r=t.getElementById(e);return r&&r.parentNode?[r]:[]}}:function(e,n,r){if(typeof n.getElementById!==p&&!r){var i=n.getElementById(e);return i?i.id===e||typeof i.getAttributeNode!==p&&i.getAttributeNode("id").value===e?[i]:t:[]}},TAG:Q?function(e,t){if(typeof t.getElementsByTagName!==p)return t.getElementsByTagName(e)}:function(e,t){var n=t.getElementsByTagName(e);if(e==="*"){var r,i=[],s=0;for(;r=n[s];s++)r.nodeType===1&&i.push(r);return i}return n},NAME:et&&function(e,t){if(typeof t.getElementsByName!==p)return t.getElementsByName(name)},CLASS:Z&&function(e,t,n){if(typeof t.getElementsByClassName!==p&&!n)return t.getElementsByClassName(e)}},relative:{">":{dir:"parentNode",first:!0}," ":{dir:"parentNode"},"+":{dir:"previousSibling",first:!0},"~":{dir:"previousSibling"}},preFilter:{ATTR:function(e){return e[1]=e[1].replace($,""),e[3]=(e[4]||e[5]||"").replace($,""),e[2]==="~="&&(e[3]=" "+e[3]+" "),e.slice(0,4)},CHILD:function(e){return e[1]=e[1].toLowerCase(),e[1]==="nth"?(e[2]||nt.error(e[0]),e[3]=+(e[3]?e[4]+(e[5]||1):2*(e[2]==="even"||e[2]==="odd")),e[4]=+(e[6]+e[7]||e[2]==="odd")):e[2]&&nt.error(e[0]),e},PSEUDO:function(e){var t,n;if(J.CHILD.test(e[0]))return null;if(e[3])e[2]=e[3];else if(t=e[4])q.test(t)&&(n=ut(t,!0))&&(n=t.indexOf(")",t.length-n)-t.length)&&(t=t.slice(0,n),e[0]=e[0].slice(0,n)),e[2]=t;return e.slice(0,3)}},filter:{ID:r?function(e){return e=e.replace($,""),function(t){return t.getAttribute("id")===e}}:function(e){return e=e.replace($,""),function(t){var n=typeof t.getAttributeNode!==p&&t.getAttributeNode("id");return n&&n.value===e}},TAG:function(e){return e==="*"?function(){return!0}:(e=e.replace($,"").toLowerCase(),function(t){return t.nodeName&&t.nodeName.toLowerCase()===e})},CLASS:function(e){var t=k[d][e+" "];return t||(t=new RegExp("(^|"+O+")"+e+"("+O+"|$)"))&&k(e,function(e){return t.test(e.className||typeof e.getAttribute!==p&&e.getAttribute("class")||"")})},ATTR:function(e,t,n){return function(r,i){var s=nt.attr(r,e);return s==null?t==="!=":t?(s+="",t==="="?s===n:t==="!="?s!==n:t==="^="?n&&s.indexOf(n)===0:t==="*="?n&&s.indexOf(n)>-1:t==="$="?n&&s.substr(s.length-n.length)===n:t==="~="?(" "+s+" ").indexOf(n)>-1:t==="|="?s===n||s.substr(0,n.length+1)===n+"-":!1):!0}},CHILD:function(e,t,n,r){return e==="nth"?function(e){var t,i,s=e.parentNode;if(n===1&&r===0)return!0;if(s){i=0;for(t=s.firstChild;t;t=t.nextSibling)if(t.nodeType===1){i++;if(e===t)break}}return i-=r,i===n||i%n===0&&i/n>=0}:function(t){var n=t;switch(e){case"only":case"first":while(n=n.previousSibling)if(n.nodeType===1)return!1;if(e==="first")return!0;n=t;case"last":while(n=n.nextSibling)if(n.nodeType===1)return!1;return!0}}},PSEUDO:function(e,t){var n,r=i.pseudos[e]||i.setFilters[e.toLowerCase()]||nt.error("unsupported pseudo: "+e);return r[d]?r(t):r.length>1?(n=[e,e,"",t],i.setFilters.hasOwnProperty(e.toLowerCase())?N(function(e,n){var i,s=r(e,t),o=s.length;while(o--)i=T.call(e,s[o]),e[i]=!(n[i]=s[o])}):function(e){return r(e,0,n)}):r}},pseudos:{not:N(function(e){var t=[],n=[],r=a(e.replace(j,"$1"));return r[d]?N(function(e,t,n,i){var s,o=r(e,null,i,[]),u=e.length;while(u--)if(s=o[u])e[u]=!(t[u]=s)}):function(e,i,s){return t[0]=e,r(t,null,s,n),!n.pop()}}),has:N(function(e){return function(t){return nt(e,t).length>0}}),contains:N(function(e){return function(t){return(t.textContent||t.innerText||s(t)).indexOf(e)>-1}}),enabled:function(e){return e.disabled===!1},disabled:function(e){return e.disabled===!0},checked:function(e){var t=e.nodeName.toLowerCase();return t==="input"&&!!e.checked||t==="option"&&!!e.selected},selected:function(e){return e.parentNode&&e.parentNode.selectedIndex,e.selected===!0},parent:function(e){return!i.pseudos.empty(e)},empty:function(e){var t;e=e.firstChild;while(e){if(e.nodeName>"@"||(t=e.nodeType)===3||t===4)return!1;e=e.nextSibling}return!0},header:function(e){return X.test(e.nodeName)},text:function(e){var t,n;return e.nodeName.toLowerCase()==="input"&&(t=e.type)==="text"&&((n=e.getAttribute("type"))==null||n.toLowerCase()===t)},radio:rt("radio"),checkbox:rt("checkbox"),file:rt("file"),password:rt("password"),image:rt("image"),submit:it("submit"),reset:it("reset"),button:function(e){var t=e.nodeName.toLowerCase();return t==="input"&&e.type==="button"||t==="button"},input:function(e){return V.test(e.nodeName)},focus:function(e){var t=e.ownerDocument;return e===t.activeElement&&(!t.hasFocus||t.hasFocus())&&!!(e.type||e.href||~e.tabIndex)},active:function(e){return e===e.ownerDocument.activeElement},first:st(function(){return[0]}),last:st(function(e,t){return[t-1]}),eq:st(function(e,t,n){return[n<0?n+t:n]}),even:st(function(e,t){for(var n=0;n=0;)e.push(r);return e}),gt:st(function(e,t,n){for(var r=n<0?n+t:n;++r",e.querySelectorAll("[selected]").length||i.push("\\["+O+"*(?:checked|disabled|ismap|multiple|readonly|selected|value)"),e.querySelectorAll(":checked").length||i.push(":checked")}),K(function(e){e.innerHTML="

      ",e.querySelectorAll("[test^='']").length&&i.push("[*^$]="+O+"*(?:\"\"|'')"),e.innerHTML="",e.querySelectorAll(":enabled").length||i.push(":enabled",":disabled")}),i=new RegExp(i.join("|")),vt=function(e,r,s,o,u){if(!o&&!u&&!i.test(e)){var a,f,l=!0,c=d,h=r,p=r.nodeType===9&&e;if(r.nodeType===1&&r.nodeName.toLowerCase()!=="object"){a=ut(e),(l=r.getAttribute("id"))?c=l.replace(n,"\\$&"):r.setAttribute("id",c),c="[id='"+c+"'] ",f=a.length;while(f--)a[f]=c+a[f].join("");h=z.test(e)&&r.parentNode||r,p=a.join(",")}if(p)try{return S.apply(s,x.call(h.querySelectorAll(p),0)),s}catch(v){}finally{l||r.removeAttribute("id")}}return t(e,r,s,o,u)},u&&(K(function(t){e=u.call(t,"div");try{u.call(t,"[test!='']:sizzle"),s.push("!=",H)}catch(n){}}),s=new RegExp(s.join("|")),nt.matchesSelector=function(t,n){n=n.replace(r,"='$1']");if(!o(t)&&!s.test(n)&&!i.test(n))try{var a=u.call(t,n);if(a||e||t.document&&t.document.nodeType!==11)return a}catch(f){}return nt(n,null,null,[t]).length>0})}(),i.pseudos.nth=i.pseudos.eq,i.filters=mt.prototype=i.pseudos,i.setFilters=new mt,nt.attr=v.attr,v.find=nt,v.expr=nt.selectors,v.expr[":"]=v.expr.pseudos,v.unique=nt.uniqueSort,v.text=nt.getText,v.isXMLDoc=nt.isXML,v.contains=nt.contains}(e);var nt=/Until$/,rt=/^(?:parents|prev(?:Until|All))/,it=/^.[^:#\[\.,]*$/,st=v.expr.match.needsContext,ot={children:!0,contents:!0,next:!0,prev:!0};v.fn.extend({find:function(e){var t,n,r,i,s,o,u=this;if(typeof e!="string")return v(e).filter(function(){for(t=0,n=u.length;t0)for(i=r;i=0:v.filter(e,this).length>0:this.filter(e).length>0)},closest:function(e,t){var n,r=0,i=this.length,s=[],o=st.test(e)||typeof e!="string"?v(e,t||this.context):0;for(;r-1:v.find.matchesSelector(n,e)){s.push(n);break}n=n.parentNode}}return s=s.length>1?v.unique(s):s,this.pushStack(s,"closest",e)},index:function(e){return e?typeof e=="string"?v.inArray(this[0],v(e)):v.inArray(e.jquery?e[0]:e,this):this[0]&&this[0].parentNode?this.prevAll().length:-1},add:function(e,t){var n=typeof e=="string"?v(e,t):v.makeArray(e&&e.nodeType?[e]:e),r=v.merge(this.get(),n);return this.pushStack(ut(n[0])||ut(r[0])?r:v.unique(r))},addBack:function(e){return this.add(e==null?this.prevObject:this.prevObject.filter(e))}}),v.fn.andSelf=v.fn.addBack,v.each({parent:function(e){var t=e.parentNode;return t&&t.nodeType!==11?t:null},parents:function(e){return v.dir(e,"parentNode")},parentsUntil:function(e,t,n){return v.dir(e,"parentNode",n)},next:function(e){return at(e,"nextSibling")},prev:function(e){return at(e,"previousSibling")},nextAll:function(e){return v.dir(e,"nextSibling")},prevAll:function(e){return v.dir(e,"previousSibling")},nextUntil:function(e,t,n){return v.dir(e,"nextSibling",n)},prevUntil:function(e,t,n){return v.dir(e,"previousSibling",n)},siblings:function(e){return v.sibling((e.parentNode||{}).firstChild,e)},children:function(e){return v.sibling(e.firstChild)},contents:function(e){return v.nodeName(e,"iframe")?e.contentDocument||e.contentWindow.document:v.merge([],e.childNodes)}},function(e,t){v.fn[e]=function(n,r){var i=v.map(this,t,n);return nt.test(e)||(r=n),r&&typeof r=="string"&&(i=v.filter(r,i)),i=this.length>1&&!ot[e]?v.unique(i):i,this.length>1&&rt.test(e)&&(i=i.reverse()),this.pushStack(i,e,l.call(arguments).join(","))}}),v.extend({filter:function(e,t,n){return n&&(e=":not("+e+")"),t.length===1?v.find.matchesSelector(t[0],e)?[t[0]]:[]:v.find.matches(e,t)},dir:function(e,n,r){var i=[],s=e[n];while(s&&s.nodeType!==9&&(r===t||s.nodeType!==1||!v(s).is(r)))s.nodeType===1&&i.push(s),s=s[n];return i},sibling:function(e,t){var n=[];for(;e;e=e.nextSibling)e.nodeType===1&&e!==t&&n.push(e);return n}});var ct="abbr|article|aside|audio|bdi|canvas|data|datalist|details|figcaption|figure|footer|header|hgroup|mark|meter|nav|output|progress|section|summary|time|video",ht=/ jQuery\d+="(?:null|\d+)"/g,pt=/^\s+/,dt=/<(?!area|br|col|embed|hr|img|input|link|meta|param)(([\w:]+)[^>]*)\/>/gi,vt=/<([\w:]+)/,mt=/]","i"),Et=/^(?:checkbox|radio)$/,St=/checked\s*(?:[^=]|=\s*.checked.)/i,xt=/\/(java|ecma)script/i,Tt=/^\s*\s*$/g,Nt={option:[1,""],legend:[1,"
      ","
      "],thead:[1,"","
      "],tr:[2,"","
      "],td:[3,"","
      "],col:[2,"","
      "],area:[1,"",""],_default:[0,"",""]},Ct=lt(i),kt=Ct.appendChild(i.createElement("div"));Nt.optgroup=Nt.option,Nt.tbody=Nt.tfoot=Nt.colgroup=Nt.caption=Nt.thead,Nt.th=Nt.td,v.support.htmlSerialize||(Nt._default=[1,"X
      ","
      "]),v.fn.extend({text:function(e){return v.access(this,function(e){return e===t?v.text(this):this.empty().append((this[0]&&this[0].ownerDocument||i).createTextNode(e))},null,e,arguments.length)},wrapAll:function(e){if(v.isFunction(e))return this.each(function(t){v(this).wrapAll(e.call(this,t))});if(this[0]){var t=v(e,this[0].ownerDocument).eq(0).clone(!0);this[0].parentNode&&t.insertBefore(this[0]),t.map(function(){var e=this;while(e.firstChild&&e.firstChild.nodeType===1)e=e.firstChild;return e}).append(this)}return this},wrapInner:function(e){return v.isFunction(e)?this.each(function(t){v(this).wrapInner(e.call(this,t))}):this.each(function(){var t=v(this),n=t.contents();n.length?n.wrapAll(e):t.append(e)})},wrap:function(e){var t=v.isFunction(e);return this.each(function(n){v(this).wrapAll(t?e.call(this,n):e)})},unwrap:function(){return this.parent().each(function(){v.nodeName(this,"body")||v(this).replaceWith(this.childNodes)}).end()},append:function(){return this.domManip(arguments,!0,function(e){(this.nodeType===1||this.nodeType===11)&&this.appendChild(e)})},prepend:function(){return this.domManip(arguments,!0,function(e){(this.nodeType===1||this.nodeType===11)&&this.insertBefore(e,this.firstChild)})},before:function(){if(!ut(this[0]))return this.domManip(arguments,!1,function(e){this.parentNode.insertBefore(e,this)});if(arguments.length){var e=v.clean(arguments);return this.pushStack(v.merge(e,this),"before",this.selector)}},after:function(){if(!ut(this[0]))return this.domManip(arguments,!1,function(e){this.parentNode.insertBefore(e,this.nextSibling)});if(arguments.length){var e=v.clean(arguments);return this.pushStack(v.merge(this,e),"after",this.selector)}},remove:function(e,t){var n,r=0;for(;(n=this[r])!=null;r++)if(!e||v.filter(e,[n]).length)!t&&n.nodeType===1&&(v.cleanData(n.getElementsByTagName("*")),v.cleanData([n])),n.parentNode&&n.parentNode.removeChild(n);return this},empty:function(){var e,t=0;for(;(e=this[t])!=null;t++){e.nodeType===1&&v.cleanData(e.getElementsByTagName("*"));while(e.firstChild)e.removeChild(e.firstChild)}return this},clone:function(e,t){return e=e==null?!1:e,t=t==null?e:t,this.map(function(){return v.clone(this,e,t)})},html:function(e){return v.access(this,function(e){var n=this[0]||{},r=0,i=this.length;if(e===t)return n.nodeType===1?n.innerHTML.replace(ht,""):t;if(typeof e=="string"&&!yt.test(e)&&(v.support.htmlSerialize||!wt.test(e))&&(v.support.leadingWhitespace||!pt.test(e))&&!Nt[(vt.exec(e)||["",""])[1].toLowerCase()]){e=e.replace(dt,"<$1>");try{for(;r1&&typeof f=="string"&&St.test(f))return this.each(function(){v(this).domManip(e,n,r)});if(v.isFunction(f))return this.each(function(i){var s=v(this);e[0]=f.call(this,i,n?s.html():t),s.domManip(e,n,r)});if(this[0]){i=v.buildFragment(e,this,l),o=i.fragment,s=o.firstChild,o.childNodes.length===1&&(o=s);if(s){n=n&&v.nodeName(s,"tr");for(u=i.cacheable||c-1;a0?this.clone(!0):this).get(),v(o[i])[t](r),s=s.concat(r);return this.pushStack(s,e,o.selector)}}),v.extend({clone:function(e,t,n){var r,i,s,o;v.support.html5Clone||v.isXMLDoc(e)||!wt.test("<"+e.nodeName+">")?o=e.cloneNode(!0):(kt.innerHTML=e.outerHTML,kt.removeChild(o=kt.firstChild));if((!v.support.noCloneEvent||!v.support.noCloneChecked)&&(e.nodeType===1||e.nodeType===11)&&!v.isXMLDoc(e)){Ot(e,o),r=Mt(e),i=Mt(o);for(s=0;r[s];++s)i[s]&&Ot(r[s],i[s])}if(t){At(e,o);if(n){r=Mt(e),i=Mt(o);for(s=0;r[s];++s)At(r[s],i[s])}}return r=i=null,o},clean:function(e,t,n,r){var s,o,u,a,f,l,c,h,p,d,m,g,y=t===i&&Ct,b=[];if(!t||typeof t.createDocumentFragment=="undefined")t=i;for(s=0;(u=e[s])!=null;s++){typeof u=="number"&&(u+="");if(!u)continue;if(typeof u=="string")if(!gt.test(u))u=t.createTextNode(u);else{y=y||lt(t),c=t.createElement("div"),y.appendChild(c),u=u.replace(dt,"<$1>"),a=(vt.exec(u)||["",""])[1].toLowerCase(),f=Nt[a]||Nt._default,l=f[0],c.innerHTML=f[1]+u+f[2];while(l--)c=c.lastChild;if(!v.support.tbody){h=mt.test(u),p=a==="table"&&!h?c.firstChild&&c.firstChild.childNodes:f[1]===""&&!h?c.childNodes:[];for(o=p.length-1;o>=0;--o)v.nodeName(p[o],"tbody")&&!p[o].childNodes.length&&p[o].parentNode.removeChild(p[o])}!v.support.leadingWhitespace&&pt.test(u)&&c.insertBefore(t.createTextNode(pt.exec(u)[0]),c.firstChild),u=c.childNodes,c.parentNode.removeChild(c)}u.nodeType?b.push(u):v.merge(b,u)}c&&(u=c=y=null);if(!v.support.appendChecked)for(s=0;(u=b[s])!=null;s++)v.nodeName(u,"input")?_t(u):typeof u.getElementsByTagName!="undefined"&&v.grep(u.getElementsByTagName("input"),_t);if(n){m=function(e){if(!e.type||xt.test(e.type))return r?r.push(e.parentNode?e.parentNode.removeChild(e):e):n.appendChild(e)};for(s=0;(u=b[s])!=null;s++)if(!v.nodeName(u,"script")||!m(u))n.appendChild(u),typeof u.getElementsByTagName!="undefined"&&(g=v.grep(v.merge([],u.getElementsByTagName("script")),m),b.splice.apply(b,[s+1,0].concat(g)),s+=g.length)}return b},cleanData:function(e,t){var n,r,i,s,o=0,u=v.expando,a=v.cache,f=v.support.deleteExpando,l=v.event.special;for(;(i=e[o])!=null;o++)if(t||v.acceptData(i)){r=i[u],n=r&&a[r];if(n){if(n.events)for(s in n.events)l[s]?v.event.remove(i,s):v.removeEvent(i,s,n.handle);a[r]&&(delete a[r],f?delete i[u]:i.removeAttribute?i.removeAttribute(u):i[u]=null,v.deletedIds.push(r))}}}}),function(){var e,t;v.uaMatch=function(e){e=e.toLowerCase();var t=/(chrome)[ \/]([\w.]+)/.exec(e)||/(webkit)[ \/]([\w.]+)/.exec(e)||/(opera)(?:.*version|)[ \/]([\w.]+)/.exec(e)||/(msie) ([\w.]+)/.exec(e)||e.indexOf("compatible")<0&&/(mozilla)(?:.*? rv:([\w.]+)|)/.exec(e)||[];return{browser:t[1]||"",version:t[2]||"0"}},e=v.uaMatch(o.userAgent),t={},e.browser&&(t[e.browser]=!0,t.version=e.version),t.chrome?t.webkit=!0:t.webkit&&(t.safari=!0),v.browser=t,v.sub=function(){function e(t,n){return new e.fn.init(t,n)}v.extend(!0,e,this),e.superclass=this,e.fn=e.prototype=this(),e.fn.constructor=e,e.sub=this.sub,e.fn.init=function(r,i){return i&&i instanceof v&&!(i instanceof e)&&(i=e(i)),v.fn.init.call(this,r,i,t)},e.fn.init.prototype=e.fn;var t=e(i);return e}}();var Dt,Pt,Ht,Bt=/alpha\([^)]*\)/i,jt=/opacity=([^)]*)/,Ft=/^(top|right|bottom|left)$/,It=/^(none|table(?!-c[ea]).+)/,qt=/^margin/,Rt=new RegExp("^("+m+")(.*)$","i"),Ut=new RegExp("^("+m+")(?!px)[a-z%]+$","i"),zt=new RegExp("^([-+])=("+m+")","i"),Wt={BODY:"block"},Xt={position:"absolute",visibility:"hidden",display:"block"},Vt={letterSpacing:0,fontWeight:400},$t=["Top","Right","Bottom","Left"],Jt=["Webkit","O","Moz","ms"],Kt=v.fn.toggle;v.fn.extend({css:function(e,n){return v.access(this,function(e,n,r){return r!==t?v.style(e,n,r):v.css(e,n)},e,n,arguments.length>1)},show:function(){return Yt(this,!0)},hide:function(){return Yt(this)},toggle:function(e,t){var n=typeof e=="boolean";return v.isFunction(e)&&v.isFunction(t)?Kt.apply(this,arguments):this.each(function(){(n?e:Gt(this))?v(this).show():v(this).hide()})}}),v.extend({cssHooks:{opacity:{get:function(e,t){if(t){var n=Dt(e,"opacity");return n===""?"1":n}}}},cssNumber:{fillOpacity:!0,fontWeight:!0,lineHeight:!0,opacity:!0,orphans:!0,widows:!0,zIndex:!0,zoom:!0},cssProps:{"float":v.support.cssFloat?"cssFloat":"styleFloat"},style:function(e,n,r,i){if(!e||e.nodeType===3||e.nodeType===8||!e.style)return;var s,o,u,a=v.camelCase(n),f=e.style;n=v.cssProps[a]||(v.cssProps[a]=Qt(f,a)),u=v.cssHooks[n]||v.cssHooks[a];if(r===t)return u&&"get"in u&&(s=u.get(e,!1,i))!==t?s:f[n];o=typeof r,o==="string"&&(s=zt.exec(r))&&(r=(s[1]+1)*s[2]+parseFloat(v.css(e,n)),o="number");if(r==null||o==="number"&&isNaN(r))return;o==="number"&&!v.cssNumber[a]&&(r+="px");if(!u||!("set"in u)||(r=u.set(e,r,i))!==t)try{f[n]=r}catch(l){}},css:function(e,n,r,i){var s,o,u,a=v.camelCase(n);return n=v.cssProps[a]||(v.cssProps[a]=Qt(e.style,a)),u=v.cssHooks[n]||v.cssHooks[a],u&&"get"in u&&(s=u.get(e,!0,i)),s===t&&(s=Dt(e,n)),s==="normal"&&n in Vt&&(s=Vt[n]),r||i!==t?(o=parseFloat(s),r||v.isNumeric(o)?o||0:s):s},swap:function(e,t,n){var r,i,s={};for(i in t)s[i]=e.style[i],e.style[i]=t[i];r=n.call(e);for(i in t)e.style[i]=s[i];return r}}),e.getComputedStyle?Dt=function(t,n){var r,i,s,o,u=e.getComputedStyle(t,null),a=t.style;return u&&(r=u.getPropertyValue(n)||u[n],r===""&&!v.contains(t.ownerDocument,t)&&(r=v.style(t,n)),Ut.test(r)&&qt.test(n)&&(i=a.width,s=a.minWidth,o=a.maxWidth,a.minWidth=a.maxWidth=a.width=r,r=u.width,a.width=i,a.minWidth=s,a.maxWidth=o)),r}:i.documentElement.currentStyle&&(Dt=function(e,t){var n,r,i=e.currentStyle&&e.currentStyle[t],s=e.style;return i==null&&s&&s[t]&&(i=s[t]),Ut.test(i)&&!Ft.test(t)&&(n=s.left,r=e.runtimeStyle&&e.runtimeStyle.left,r&&(e.runtimeStyle.left=e.currentStyle.left),s.left=t==="fontSize"?"1em":i,i=s.pixelLeft+"px",s.left=n,r&&(e.runtimeStyle.left=r)),i===""?"auto":i}),v.each(["height","width"],function(e,t){v.cssHooks[t]={get:function(e,n,r){if(n)return e.offsetWidth===0&&It.test(Dt(e,"display"))?v.swap(e,Xt,function(){return tn(e,t,r)}):tn(e,t,r)},set:function(e,n,r){return Zt(e,n,r?en(e,t,r,v.support.boxSizing&&v.css(e,"boxSizing")==="border-box"):0)}}}),v.support.opacity||(v.cssHooks.opacity={get:function(e,t){return jt.test((t&&e.currentStyle?e.currentStyle.filter:e.style.filter)||"")?.01*parseFloat(RegExp.$1)+"":t?"1":""},set:function(e,t){var n=e.style,r=e.currentStyle,i=v.isNumeric(t)?"alpha(opacity="+t*100+")":"",s=r&&r.filter||n.filter||"";n.zoom=1;if(t>=1&&v.trim(s.replace(Bt,""))===""&&n.removeAttribute){n.removeAttribute("filter");if(r&&!r.filter)return}n.filter=Bt.test(s)?s.replace(Bt,i):s+" "+i}}),v(function(){v.support.reliableMarginRight||(v.cssHooks.marginRight={get:function(e,t){return v.swap(e,{display:"inline-block"},function(){if(t)return Dt(e,"marginRight")})}}),!v.support.pixelPosition&&v.fn.position&&v.each(["top","left"],function(e,t){v.cssHooks[t]={get:function(e,n){if(n){var r=Dt(e,t);return Ut.test(r)?v(e).position()[t]+"px":r}}}})}),v.expr&&v.expr.filters&&(v.expr.filters.hidden=function(e){return e.offsetWidth===0&&e.offsetHeight===0||!v.support.reliableHiddenOffsets&&(e.style&&e.style.display||Dt(e,"display"))==="none"},v.expr.filters.visible=function(e){return!v.expr.filters.hidden(e)}),v.each({margin:"",padding:"",border:"Width"},function(e,t){v.cssHooks[e+t]={expand:function(n){var r,i=typeof n=="string"?n.split(" "):[n],s={};for(r=0;r<4;r++)s[e+$t[r]+t]=i[r]||i[r-2]||i[0];return s}},qt.test(e)||(v.cssHooks[e+t].set=Zt)});var rn=/%20/g,sn=/\[\]$/,on=/\r?\n/g,un=/^(?:color|date|datetime|datetime-local|email|hidden|month|number|password|range|search|tel|text|time|url|week)$/i,an=/^(?:select|textarea)/i;v.fn.extend({serialize:function(){return v.param(this.serializeArray())},serializeArray:function(){return this.map(function(){return this.elements?v.makeArray(this.elements):this}).filter(function(){return this.name&&!this.disabled&&(this.checked||an.test(this.nodeName)||un.test(this.type))}).map(function(e,t){var n=v(this).val();return n==null?null:v.isArray(n)?v.map(n,function(e,n){return{name:t.name,value:e.replace(on,"\r\n")}}):{name:t.name,value:n.replace(on,"\r\n")}}).get()}}),v.param=function(e,n){var r,i=[],s=function(e,t){t=v.isFunction(t)?t():t==null?"":t,i[i.length]=encodeURIComponent(e)+"="+encodeURIComponent(t)};n===t&&(n=v.ajaxSettings&&v.ajaxSettings.traditional);if(v.isArray(e)||e.jquery&&!v.isPlainObject(e))v.each(e,function(){s(this.name,this.value)});else for(r in e)fn(r,e[r],n,s);return i.join("&").replace(rn,"+")};var ln,cn,hn=/#.*$/,pn=/^(.*?):[ \t]*([^\r\n]*)\r?$/mg,dn=/^(?:about|app|app\-storage|.+\-extension|file|res|widget):$/,vn=/^(?:GET|HEAD)$/,mn=/^\/\//,gn=/\?/,yn=/)<[^<]*)*<\/script>/gi,bn=/([?&])_=[^&]*/,wn=/^([\w\+\.\-]+:)(?:\/\/([^\/?#:]*)(?::(\d+)|)|)/,En=v.fn.load,Sn={},xn={},Tn=["*/"]+["*"];try{cn=s.href}catch(Nn){cn=i.createElement("a"),cn.href="",cn=cn.href}ln=wn.exec(cn.toLowerCase())||[],v.fn.load=function(e,n,r){if(typeof e!="string"&&En)return En.apply(this,arguments);if(!this.length)return this;var i,s,o,u=this,a=e.indexOf(" ");return a>=0&&(i=e.slice(a,e.length),e=e.slice(0,a)),v.isFunction(n)?(r=n,n=t):n&&typeof n=="object"&&(s="POST"),v.ajax({url:e,type:s,dataType:"html",data:n,complete:function(e,t){r&&u.each(r,o||[e.responseText,t,e])}}).done(function(e){o=arguments,u.html(i?v("
      ").append(e.replace(yn,"")).find(i):e)}),this},v.each("ajaxStart ajaxStop ajaxComplete ajaxError ajaxSuccess ajaxSend".split(" "),function(e,t){v.fn[t]=function(e){return this.on(t,e)}}),v.each(["get","post"],function(e,n){v[n]=function(e,r,i,s){return v.isFunction(r)&&(s=s||i,i=r,r=t),v.ajax({type:n,url:e,data:r,success:i,dataType:s})}}),v.extend({getScript:function(e,n){return v.get(e,t,n,"script")},getJSON:function(e,t,n){return v.get(e,t,n,"json")},ajaxSetup:function(e,t){return t?Ln(e,v.ajaxSettings):(t=e,e=v.ajaxSettings),Ln(e,t),e},ajaxSettings:{url:cn,isLocal:dn.test(ln[1]),global:!0,type:"GET",contentType:"application/x-www-form-urlencoded; charset=UTF-8",processData:!0,async:!0,accepts:{xml:"application/xml, text/xml",html:"text/html",text:"text/plain",json:"application/json, text/javascript","*":Tn},contents:{xml:/xml/,html:/html/,json:/json/},responseFields:{xml:"responseXML",text:"responseText"},converters:{"* text":e.String,"text html":!0,"text json":v.parseJSON,"text xml":v.parseXML},flatOptions:{context:!0,url:!0}},ajaxPrefilter:Cn(Sn),ajaxTransport:Cn(xn),ajax:function(e,n){function T(e,n,s,a){var l,y,b,w,S,T=n;if(E===2)return;E=2,u&&clearTimeout(u),o=t,i=a||"",x.readyState=e>0?4:0,s&&(w=An(c,x,s));if(e>=200&&e<300||e===304)c.ifModified&&(S=x.getResponseHeader("Last-Modified"),S&&(v.lastModified[r]=S),S=x.getResponseHeader("Etag"),S&&(v.etag[r]=S)),e===304?(T="notmodified",l=!0):(l=On(c,w),T=l.state,y=l.data,b=l.error,l=!b);else{b=T;if(!T||e)T="error",e<0&&(e=0)}x.status=e,x.statusText=(n||T)+"",l?d.resolveWith(h,[y,T,x]):d.rejectWith(h,[x,T,b]),x.statusCode(g),g=t,f&&p.trigger("ajax"+(l?"Success":"Error"),[x,c,l?y:b]),m.fireWith(h,[x,T]),f&&(p.trigger("ajaxComplete",[x,c]),--v.active||v.event.trigger("ajaxStop"))}typeof e=="object"&&(n=e,e=t),n=n||{};var r,i,s,o,u,a,f,l,c=v.ajaxSetup({},n),h=c.context||c,p=h!==c&&(h.nodeType||h instanceof v)?v(h):v.event,d=v.Deferred(),m=v.Callbacks("once memory"),g=c.statusCode||{},b={},w={},E=0,S="canceled",x={readyState:0,setRequestHeader:function(e,t){if(!E){var n=e.toLowerCase();e=w[n]=w[n]||e,b[e]=t}return this},getAllResponseHeaders:function(){return E===2?i:null},getResponseHeader:function(e){var n;if(E===2){if(!s){s={};while(n=pn.exec(i))s[n[1].toLowerCase()]=n[2]}n=s[e.toLowerCase()]}return n===t?null:n},overrideMimeType:function(e){return E||(c.mimeType=e),this},abort:function(e){return e=e||S,o&&o.abort(e),T(0,e),this}};d.promise(x),x.success=x.done,x.error=x.fail,x.complete=m.add,x.statusCode=function(e){if(e){var t;if(E<2)for(t in e)g[t]=[g[t],e[t]];else t=e[x.status],x.always(t)}return this},c.url=((e||c.url)+"").replace(hn,"").replace(mn,ln[1]+"//"),c.dataTypes=v.trim(c.dataType||"*").toLowerCase().split(y),c.crossDomain==null&&(a=wn.exec(c.url.toLowerCase()),c.crossDomain=!(!a||a[1]===ln[1]&&a[2]===ln[2]&&(a[3]||(a[1]==="http:"?80:443))==(ln[3]||(ln[1]==="http:"?80:443)))),c.data&&c.processData&&typeof c.data!="string"&&(c.data=v.param(c.data,c.traditional)),kn(Sn,c,n,x);if(E===2)return x;f=c.global,c.type=c.type.toUpperCase(),c.hasContent=!vn.test(c.type),f&&v.active++===0&&v.event.trigger("ajaxStart");if(!c.hasContent){c.data&&(c.url+=(gn.test(c.url)?"&":"?")+c.data,delete c.data),r=c.url;if(c.cache===!1){var N=v.now(),C=c.url.replace(bn,"$1_="+N);c.url=C+(C===c.url?(gn.test(c.url)?"&":"?")+"_="+N:"")}}(c.data&&c.hasContent&&c.contentType!==!1||n.contentType)&&x.setRequestHeader("Content-Type",c.contentType),c.ifModified&&(r=r||c.url,v.lastModified[r]&&x.setRequestHeader("If-Modified-Since",v.lastModified[r]),v.etag[r]&&x.setRequestHeader("If-None-Match",v.etag[r])),x.setRequestHeader("Accept",c.dataTypes[0]&&c.accepts[c.dataTypes[0]]?c.accepts[c.dataTypes[0]]+(c.dataTypes[0]!=="*"?", "+Tn+"; q=0.01":""):c.accepts["*"]);for(l in c.headers)x.setRequestHeader(l,c.headers[l]);if(!c.beforeSend||c.beforeSend.call(h,x,c)!==!1&&E!==2){S="abort";for(l in{success:1,error:1,complete:1})x[l](c[l]);o=kn(xn,c,n,x);if(!o)T(-1,"No Transport");else{x.readyState=1,f&&p.trigger("ajaxSend",[x,c]),c.async&&c.timeout>0&&(u=setTimeout(function(){x.abort("timeout")},c.timeout));try{E=1,o.send(b,T)}catch(k){if(!(E<2))throw k;T(-1,k)}}return x}return x.abort()},active:0,lastModified:{},etag:{}});var Mn=[],_n=/\?/,Dn=/(=)\?(?=&|$)|\?\?/,Pn=v.now();v.ajaxSetup({jsonp:"callback",jsonpCallback:function(){var e=Mn.pop()||v.expando+"_"+Pn++;return this[e]=!0,e}}),v.ajaxPrefilter("json jsonp",function(n,r,i){var s,o,u,a=n.data,f=n.url,l=n.jsonp!==!1,c=l&&Dn.test(f),h=l&&!c&&typeof a=="string"&&!(n.contentType||"").indexOf("application/x-www-form-urlencoded")&&Dn.test(a);if(n.dataTypes[0]==="jsonp"||c||h)return s=n.jsonpCallback=v.isFunction(n.jsonpCallback)?n.jsonpCallback():n.jsonpCallback,o=e[s],c?n.url=f.replace(Dn,"$1"+s):h?n.data=a.replace(Dn,"$1"+s):l&&(n.url+=(_n.test(f)?"&":"?")+n.jsonp+"="+s),n.converters["script json"]=function(){return u||v.error(s+" was not called"),u[0]},n.dataTypes[0]="json",e[s]=function(){u=arguments},i.always(function(){e[s]=o,n[s]&&(n.jsonpCallback=r.jsonpCallback,Mn.push(s)),u&&v.isFunction(o)&&o(u[0]),u=o=t}),"script"}),v.ajaxSetup({accepts:{script:"text/javascript, application/javascript, application/ecmascript, application/x-ecmascript"},contents:{script:/javascript|ecmascript/},converters:{"text script":function(e){return v.globalEval(e),e}}}),v.ajaxPrefilter("script",function(e){e.cache===t&&(e.cache=!1),e.crossDomain&&(e.type="GET",e.global=!1)}),v.ajaxTransport("script",function(e){if(e.crossDomain){var n,r=i.head||i.getElementsByTagName("head")[0]||i.documentElement;return{send:function(s,o){n=i.createElement("script"),n.async="async",e.scriptCharset&&(n.charset=e.scriptCharset),n.src=e.url,n.onload=n.onreadystatechange=function(e,i){if(i||!n.readyState||/loaded|complete/.test(n.readyState))n.onload=n.onreadystatechange=null,r&&n.parentNode&&r.removeChild(n),n=t,i||o(200,"success")},r.insertBefore(n,r.firstChild)},abort:function(){n&&n.onload(0,1)}}}});var Hn,Bn=e.ActiveXObject?function(){for(var e in Hn)Hn[e](0,1)}:!1,jn=0;v.ajaxSettings.xhr=e.ActiveXObject?function(){return!this.isLocal&&Fn()||In()}:Fn,function(e){v.extend(v.support,{ajax:!!e,cors:!!e&&"withCredentials"in e})}(v.ajaxSettings.xhr()),v.support.ajax&&v.ajaxTransport(function(n){if(!n.crossDomain||v.support.cors){var r;return{send:function(i,s){var o,u,a=n.xhr();n.username?a.open(n.type,n.url,n.async,n.username,n.password):a.open(n.type,n.url,n.async);if(n.xhrFields)for(u in n.xhrFields)a[u]=n.xhrFields[u];n.mimeType&&a.overrideMimeType&&a.overrideMimeType(n.mimeType),!n.crossDomain&&!i["X-Requested-With"]&&(i["X-Requested-With"]="XMLHttpRequest");try{for(u in i)a.setRequestHeader(u,i[u])}catch(f){}a.send(n.hasContent&&n.data||null),r=function(e,i){var u,f,l,c,h;try{if(r&&(i||a.readyState===4)){r=t,o&&(a.onreadystatechange=v.noop,Bn&&delete Hn[o]);if(i)a.readyState!==4&&a.abort();else{u=a.status,l=a.getAllResponseHeaders(),c={},h=a.responseXML,h&&h.documentElement&&(c.xml=h);try{c.text=a.responseText}catch(p){}try{f=a.statusText}catch(p){f=""}!u&&n.isLocal&&!n.crossDomain?u=c.text?200:404:u===1223&&(u=204)}}}catch(d){i||s(-1,d)}c&&s(u,f,c,l)},n.async?a.readyState===4?setTimeout(r,0):(o=++jn,Bn&&(Hn||(Hn={},v(e).unload(Bn)),Hn[o]=r),a.onreadystatechange=r):r()},abort:function(){r&&r(0,1)}}}});var qn,Rn,Un=/^(?:toggle|show|hide)$/,zn=new RegExp("^(?:([-+])=|)("+m+")([a-z%]*)$","i"),Wn=/queueHooks$/,Xn=[Gn],Vn={"*":[function(e,t){var n,r,i=this.createTween(e,t),s=zn.exec(t),o=i.cur(),u=+o||0,a=1,f=20;if(s){n=+s[2],r=s[3]||(v.cssNumber[e]?"":"px");if(r!=="px"&&u){u=v.css(i.elem,e,!0)||n||1;do a=a||".5",u/=a,v.style(i.elem,e,u+r);while(a!==(a=i.cur()/o)&&a!==1&&--f)}i.unit=r,i.start=u,i.end=s[1]?u+(s[1]+1)*n:n}return i}]};v.Animation=v.extend(Kn,{tweener:function(e,t){v.isFunction(e)?(t=e,e=["*"]):e=e.split(" ");var n,r=0,i=e.length;for(;r-1,f={},l={},c,h;a?(l=i.position(),c=l.top,h=l.left):(c=parseFloat(o)||0,h=parseFloat(u)||0),v.isFunction(t)&&(t=t.call(e,n,s)),t.top!=null&&(f.top=t.top-s.top+c),t.left!=null&&(f.left=t.left-s.left+h),"using"in t?t.using.call(e,f):i.css(f)}},v.fn.extend({position:function(){if(!this[0])return;var e=this[0],t=this.offsetParent(),n=this.offset(),r=er.test(t[0].nodeName)?{top:0,left:0}:t.offset();return n.top-=parseFloat(v.css(e,"marginTop"))||0,n.left-=parseFloat(v.css(e,"marginLeft"))||0,r.top+=parseFloat(v.css(t[0],"borderTopWidth"))||0,r.left+=parseFloat(v.css(t[0],"borderLeftWidth"))||0,{top:n.top-r.top,left:n.left-r.left}},offsetParent:function(){return this.map(function(){var e=this.offsetParent||i.body;while(e&&!er.test(e.nodeName)&&v.css(e,"position")==="static")e=e.offsetParent;return e||i.body})}}),v.each({scrollLeft:"pageXOffset",scrollTop:"pageYOffset"},function(e,n){var r=/Y/.test(n);v.fn[e]=function(i){return v.access(this,function(e,i,s){var o=tr(e);if(s===t)return o?n in o?o[n]:o.document.documentElement[i]:e[i];o?o.scrollTo(r?v(o).scrollLeft():s,r?s:v(o).scrollTop()):e[i]=s},e,i,arguments.length,null)}}),v.each({Height:"height",Width:"width"},function(e,n){v.each({padding:"inner"+e,content:n,"":"outer"+e},function(r,i){v.fn[i]=function(i,s){var o=arguments.length&&(r||typeof i!="boolean"),u=r||(i===!0||s===!0?"margin":"border");return v.access(this,function(n,r,i){var s;return v.isWindow(n)?n.document.documentElement["client"+e]:n.nodeType===9?(s=n.documentElement,Math.max(n.body["scroll"+e],s["scroll"+e],n.body["offset"+e],s["offset"+e],s["client"+e])):i===t?v.css(n,r,i,u):v.style(n,r,i,u)},n,o?i:t,o,null)}})}),e.jQuery=e.$=v,typeof define=="function"&&define.amd&&define.amd.jQuery&&define("jquery",[],function(){return v})})(window); diff --git a/website/posts.md b/website/posts.md new file mode 100644 index 00000000..09fcb124 --- /dev/null +++ b/website/posts.md @@ -0,0 +1,15 @@ +--- +layout: page +title: Posts +--- +### Posts + +
      +
        + {% for post in site.posts %} +
      • + {{ post.date | date: "%B %e, %Y" }} · {{post.author}} · {{ post.title }} +
        • + {% endfor %} +
      +
      diff --git a/website/rss.xml b/website/rss.xml new file mode 100644 index 00000000..2bea1282 --- /dev/null +++ b/website/rss.xml @@ -0,0 +1,20 @@ +--- +layout: none +--- + + + + {{ site.name }} - Articles + {{ site.description }} + {{ site.url }} + {% for post in site.posts %} + + {{ post.title }} + {{ post.content | xml_escape }} + {{ post.date | date: "%a, %d %b %Y %H:%M:%S %z" }} + {{ post.link | escape }} + {{ site.url }}{{ post.url }} + + {% endfor %} + + diff --git a/website/semantics/CloudHaskellSemantics.pdf b/website/semantics/CloudHaskellSemantics.pdf new file mode 100644 index 00000000..6f01eb85 Binary files /dev/null and b/website/semantics/CloudHaskellSemantics.pdf differ diff --git a/website/semantics/CloudHaskellSemantics.tex b/website/semantics/CloudHaskellSemantics.tex new file mode 100644 index 00000000..5a223e5b --- /dev/null +++ b/website/semantics/CloudHaskellSemantics.tex @@ -0,0 +1,706 @@ +\documentclass{article} +\usepackage[margin=2.5cm]{geometry} +\usepackage{amsmath, amssymb, stmaryrd} +\usepackage{mathpazo, times} +\usepackage{float} +\usepackage{listings} + +\newcommand{\sLam}[2]{\lambda {#1} \cdot {#2}} +\newcommand{\sApp}[2]{{#1} {#2}} +\newcommand{\sBind}[2]{{#1} \mathrel{\texttt{>}\!\!\texttt{>}\!\texttt{=}} {#2}} +\newcommand{\sReturn}{\mathtt{return}} +\newcommand{\sThrow}[1]{\mathtt{throw} \; {#1}} +\newcommand{\sCatch}[2]{\mathtt{catch} \; {#1} \; {#2}} + +\newcommand{\sExpect}{\mathtt{expect}} +\newcommand{\sSend}{\mathtt{send}} +\newcommand{\sSpawn}{\mathtt{spawn}} +\newcommand{\sLink}{\mathtt{link}} +\newcommand{\sReconnect}{\mathtt{reconnect}} +\newcommand{\sNewChan}{\mathtt{newChan}} +\newcommand{\sSendChan}{\mathtt{sendChan}} +\newcommand{\sReceiveChan}{\mathtt{receiveChan}} +\newcommand{\sMonitor}{\mathtt{monitor}} + +\DeclareMathOperator{\sNodeOf}{node} +\DeclareMathOperator{\sProcessOf}{process} + +\newcommand{\sSpawned}{\mathtt{spawned}} + +\newcommand{\sExtend}[1]{\mathrel{\triangleright_{#1}}} + +\newcommand{\sPar}{\mathrel{\parallel}} +\newcommand{\sProc}[2]{{#1}_{#2}} + +\newcommand{\sNid}{\ensuremath{\mathit{nid}}} +\newcommand{\sPid}{\ensuremath{\mathit{pid}}} +\newcommand{\sCid}{\ensuremath{\mathit{cid}}} + +\newcommand{\sId}{\ensuremath{\mathit{id}}} +\newcommand{\sRef}{\ensuremath{\mathit{ref}}} + +\newcommand{\sLinks}{\ensuremath{\mathit{links}}} +\newcommand{\sNode}[3]{\left[{#1} ; {#2}\right]_{#3}} +\newcommand{\sSystem}[4]{\left\langle #1 ; #2 ; #3 ; #4 \right\rangle} +\newcommand{\sNodes}{\mathcal{N}} +\newcommand{\sQueue}{\mathcal{Q}} +\newcommand{\sProcesses}{\mathcal{P}} +\newcommand{\sBlacklist}{\mathcal{B}} +\newcommand{\sMonitors}{\mathcal{M}} + +\newcommand{\sJust}[1]{\mathtt{Just} \; {#1}} +\newcommand{\sNothing}{\mathtt{Nothing}} + +\newcommand{\sCtxt}[1]{\mathbb{#1}} + +\newcommand{\sSenders}{\mathit{senders}} + +\newcommand{\OR}{\mathrel{|}} +\newcommand{\where}{\mathrel{|}} + +\floatstyle{boxed} +\restylefloat{figure} + +\lstset{basicstyle=\ttfamily\small} + +\begin{document} + +\title{Cloud Haskell Semantics (DRAFT)} +\author{Well-Typed LLP} +\date{\today} + +\maketitle + +\section{Introduction} + +Cloud Haskell brings Erlang-style concurrency to Haskell in the form of a +library.\footnote{\texttt{http://hackage.haskell.org/package/distributed-process}} +The original publication \cite{cloudhaskell} is a good introduction to Cloud +Haskell, and is accompanied by an ever-growing number of resouces, collected on +the Haskell +Wiki.\footnote{\texttt{http://www.haskell.org/haskellwiki/Cloud\_Haskell}} The +current document augments the original publication about Cloud Haskell by +giving a precise semantics to the Cloud Haskell primitives. It is meant as a +reference, not an introduction. + +The original Cloud Haskell paper stipulates that messages are ``asynchronous, +reliable, and buffered'', but does not describe how this can be achieved. +Understanding ``reliable'' to mean ``reliable ordered'' (or ``TCP-like''), +the reliability of message delivery comes from the reliability of the +underlying network protocol---up to a point. + +The problem is that the underlying network protocol is connection-oriented, but +Cloud Haskell is not. Intuitively, when $P$ sends a message to $Q$, we open a +reliable-ordered connection from $P$ to $Q$. Reliability of message delivery +now follows from reliability of the network protocol, until $P$ somehow gets +disconnected from $Q$. If $P$ now sends another message to $Q$, the +implementation cannot simply reconnect: after all, some messages that were sent +on the first connection might not have been delivered. This means that $P$ +might send $m_1, m_2, m_3$ to $Q$, but $Q$ will receive $m_1, +m_3$.\footnote{Indeed, message passing in Erlang is ordered but unreliable for +the same reason \cite{erlang}.} + +One (non-)solution is for $P$ to buffer all messages it sends to $Q$, and +remove messages from this buffer only when $Q$ acknowledges that it received +them. On a reconnect $P$ must ask which message $Q$ last received, and +retransmit the rest. This means that when $P$ gets disconnected from $Q$, it +must infinitely buffer all messages sent to $Q$ (until a connection is +reestablished). However, infinite buffering is too strong a requirement; +moreover, this is unsatisfactory because it means implementing a reliable +protocol on top of the underlying reliable network protocol. We would like a +different solution. + +Instead, Cloud Haskell does \emph{not} attempt to reconnect automatically, but +provides a $\sReconnect$ primitive which gives programmers the option of +reconnecting manually. This is an explicit acknowledgement from the programmer +that message loss might occur, and forces them to consider how such loss might +be dealt with. + +The semantics we present is based on \cite{unified}, which we will refer to the +as the ``Unified'' semantics. However, we will present the semantics in a more +``Haskell'' style following the semantics for STM \cite{stm}. It differs from +the Unified semantics in that +% +\begin{enumerate} +\item We introduce an explicit notion of \textit{reconnecting} (with potential +message loss) +\item We simplify the semantics: we ``flatten'' sets of nodes of processes as +sets of processes (but assume a mapping from process identifiers to node +identifiers), do not have per-process mailboxes (but only the system queue or +``ether'') and do not have an explicit concept of node controllers +\end{enumerate} +% +Our semantics differs from the STM semantics in that we pretend that the Cloud +Haskell \texttt{Process} monad is the top-level monad, and do not consider the +\texttt{IO} monad at all. Current imprecisions with respect to the ``real'' +Cloud Haskell are +% +\begin{enumerate} +\item We ignore the issue of serializability, other than to say that the +semantics will get stuck when trying to send a non-serializable payload; +consequently, we do not formalize $\mathtt{static}$ +\item We do not formalize all Cloud Haskell primitives (merging of ports, +``advanced messaging'', and others) +\item Some of the concepts that we do formalize are lower-level concepts; for +instance, the primitive $\sSpawn$ that we formalize is asynchronous (following +the Unified semantics); a synchronous construct can be derived. +\end{enumerate} + +\section{Preliminaries} + +Cloud Haskell Processes run on \emph{nodes}. Processes communicate by sending +messages to each other (directly or using typed channels). Processes can also +send messages to nodes (for instance, a request to spawn or monitor a process). + +We assume disjoint countable sets $\mathtt{NodeId}$, $\mathtt{ProcessId}$, and +$\mathtt{ChannelId}$, changed over by \sNid, \sPid{} and \sCid{} respectively, +and representing process identifiers, node identifiers, and (typed) channel +identifiers. We assume the existence of total functions +% +\begin{equation*} +\begin{array}{r@{\;:\;}l} +\sNodeOf & (\mathtt{ProcessId} \uplus \mathtt{ChannelId}) \rightarrow \mathtt{NodeId} \\ +\sProcessOf & \mathtt{ChannelId} \rightarrow \mathtt{ProcessId} +\end{array} +\end{equation*} +% +and define +$$\mathtt{Identifier} = \mathtt{NodeId} \uplus \mathtt{ProcessId} \uplus \mathtt{ChannelId}$$ +and let $\sId$ range over $\mathtt{Identifier}$. + +We represent a process as a pair $\sProc{M}{\sPid}$ of a term $M$ and a process +ID $\sPid$. We will denote a set of processes as +% + $$\sProc{M}{\sPid} \sPar \cdots \sPar \sProc{N}{\sPid'}$$ +% +A \emph{system} + $\sSystem{\sProcesses}{\sQueue}{\sBlacklist}{\sMonitors}$ +is a tuple containing a set $\sProcesses$ of processes, a \emph{system +queue} $\sQueue$, a \emph{blacklist} $\sBlacklist$, and a set of monitors +$\sMonitors$. +The set of monitors $\sMonitors$ is a set of tuples + $(\sId_\mathit{to}, \sPid_\mathit{fr}, \sNid, \sRef)$ +which records that node \sNid{} knows that process $\sPid_\mathit{fr}$ is +monitoring $\sId_\mathit{to}$ ($\sRef$ is the monitor reference). The system +queue is a set of triples $(\sId_\mathit{to}, \sId_\mathit{fr}, +\mathit{message})$ of messages that have been sent but not yet processed. The +blacklist records disconnections and is represented as a of pairs +$(\sId_\mathit{to}, \sId_\mathit{fr})$. + +\section{Semantics} + +We follow the STM semantics as closely as possible. The language is the same +except for the primitives considered, and we use the same concept of evaluation +contexts: + +\begin{equation*} +\begin{array}{llll} +\text{value} & V & ::= & \sId \OR + \sLam{x}{M} \OR + \sReturn \; M \OR + \sBind{M}{N} \OR + \sThrow{M} \OR \sCatch{M}{N} \OR \\ + &&& \sExpect \OR + \sSend \; \sPid \; M \OR + \sSpawn \; \sNid \; M \OR + \sMonitor \; \sId +\\ +\text{term} & M, N & ::= & x \OR + V \OR + \sApp{M}{N} \OR + \cdots \\ +\\ +\text{Evaluation} & \sCtxt{E} & ::= & [] \OR \sBind{\sCtxt{E}}{M} \OR \sCatch{\sCtxt{E}}{M} \\ +\text{context} & \sCtxt{P}_\sPid & ::= & \sCtxt{E}[]_\sPid \sPar \sProcesses +\end{array} +\end{equation*} +% +Indeed, the ``administrative'' transitions are identical +(Figure~\ref{fig:administrative}). + +\begin{figure} +\small +\begin{equation*} +\frac{ + \llbracket M \rrbracket = V \qquad + M \neq V +}{ + M \rightarrow V +} \textsc{Eval} +\qquad +\frac{ + M \rightarrow N +}{ + \sSystem{\sCtxt{P}[M]_\sPid} + {\sQueue} + {\sBlacklist} + {\sMonitors} +\rightarrow + \sSystem{\sCtxt{P}[N]_\sPid} + {\sQueue} + {\sBlacklist} + {\sMonitors} +} \textsc{Admin} +\end{equation*} +% +\begin{equation*} +\begin{array}{r@{\;\rightarrow\;}ll@{\hspace{2em}}r@{\;\rightarrow\;}ll} +\sBind{\sReturn \; N}{M} & M \; N & \textsc{Bind} & \sCatch{(\sReturn \; M)}{N} & \sReturn \; M & \textsc{Catch}_1 \\ +\sBind{\sThrow{N}}{M} & \sThrow{N} & \textsc{Throw} & \sCatch{(\sThrow M)}{N} & N \; M & \textsc{Catch}_2 \\ +\end{array} +\end{equation*} +% +\caption{\label{fig:administrative}Administrative Transitions} +\end{figure} + +\subsection{Disconnect and Reconnect} + +Figure~\ref{fig:disconnect} gives the semantics for disconnecting and +reconnecting. Rule \textsc{Disconnect} models random network disconnect +between nodes $\sNid_1$ and $\sNid_2$. We assume that entire \emph{nodes} get +disconnected from each other, not individual processes. \emph{Reconnecting} +however is on a per connection basis (\textsc{Recon-Ex}). Connections to and +from node controllers can be implicitly reconnected ($\textsc{Recon-Im}_1$ and +$\textsc{Recon-Im}_2$). + +\begin{figure} +\small +\begin{equation*} +\frac{ + \sNid_1 \neq \sNid_2 +}{ + \sSystem{\sProcesses}{\sQueue}{\sBlacklist}{\sMonitors} +\rightarrow + \sSystem{\sProcesses}{\sQueue}{\sBlacklist \cup (\overline{\sNid_1} \times \overline{\sNid_2})}{\sMonitors} +} \textsc{Disconnect} +\end{equation*} +% +\begin{equation*} +\frac{ +}{ + \sSystem{\sCtxt{P}[ \sReconnect \; \sId_\mathit{to} ]_{\sPid_\mathit{fr}}} + {\sQueue} + {\sBlacklist} + {\sMonitors} +\rightarrow + \sSystem{\sCtxt{P}[ \sReturn \; () ]_\sPid} + {\sQueue} + {\sBlacklist \backslash (\sId_\mathit{to}, \sPid_\mathit{fr})} + {\sMonitors} +} \textsc{Recon-Ex} +\end{equation*} +% +\begin{equation*} +\frac{ +}{ + \sSystem{\sProcesses}{\sQueue}{\sBlacklist, (\sNid_\mathit{to}, \sId_\mathit{fr})}{\sMonitors} +\rightarrow + \sSystem{\sProcesses}{\sQueue}{\sBlacklist}{\sMonitors} +} \textsc{Recon-Im}_1 +\qquad +\frac{ +}{ + \sSystem{\sProcesses}{\sQueue}{\sBlacklist, (\sId_\mathit{to}, \sNid_\mathit{fr})}{\sMonitors} +\rightarrow + \sSystem{\sProcesses}{\sQueue}{\sBlacklist}{\sMonitors} +} \textsc{Recon-Im}_2 +\end{equation*} +% +where +% +\begin{equation*} +\overline{\sNid} \subset \mathtt{Identifier} + = \{ \sNid \} \cup + \{ \sPid \where \sNodeOf(\sPid) = \sNid \} \cup + \{ \sCid \where \sNodeOf(\sCid) = \sNid \} +\end{equation*} +\caption{\label{fig:disconnect}Disconnect and Reconnect} +\end{figure} + +\subsection{Communication} + +The semantics for the basic primitives are listed in Figure~\ref{fig:basic}. +Once a connection has been blacklisted, no further messages can be sent across +that connection (until an explicit or implicit reconnect). + +Message passing is ordered but only for a given sender and receiver; no +ordering guarantees exist between messages sent by different processes. For +that reason rules \textsc{Expect}, \textsc{ReceiveChan} and \textsc{Spawn-Exec} +choose the \emph{first} message of a \emph{randomly chosen} sender. + +Since the semantics is not type-driven, we represent typed channels simply as +an identifier with an annotation whether it is the send-end ($\sCid^s$) or the +receive end ($\sCid^r$) of the channel (rules \textsc{NewChan}, +\textsc{SendChan} and \textsc{ReceiveChan}). + +Spawning finally is asynchronous. When process $P$ spawns process $Q$ on node +$\sNid$ (rule \textsc{Spawn-Async}) a message is sent to node $\sNid$ (which +may, of course, never arrive). When the remote node receives the message and +actually spawns $Q$ (rule \textsc{Spawn-Exec}) it sends a message back to $P$ +with $Q$'s process ID. In Cloud Haskell this primitive is called +\texttt{spawnAsync}, and the Cloud Haskell \texttt{spawn} primitive is defined +in terms of \texttt{spawnAsync} (we do not consider the synchronous version in +this document). + +\begin{figure} +\small +\begin{equation*} +\frac{ +}{ + \sSystem{\sCtxt{P}[ \sSend \; \sPid_\mathit{to} \; M ]_{\sPid_\mathit{fr}}} + {\sQueue} + {\sBlacklist} + {\sMonitors} +\rightarrow + \sSystem{\sCtxt{P}[ \sReturn \; () ]_{\sPid_\mathit{fr}}} + {\sQueue \sExtend{\sBlacklist} (\sPid_\mathit{to}, \sPid_\mathit{fr}, M)} + {\sBlacklist} + {\sMonitors} +} \textsc{Send} +\end{equation*} +% +\begin{equation*} +\frac{ + \sId_{\mathit{fr}} \notin \sSenders(\sQueue) +}{ + \sSystem{\sCtxt{P}[ \sExpect ]_{\sPid_\mathit{to}}} + {\sQueue, (\sPid_\mathit{to}, \sId_\mathit{fr}, M), \sQueue'} + {\sBlacklist} + {\sMonitors} +\rightarrow + \sSystem{\sCtxt{P}[ \sReturn \; M ]_{\sPid_\mathit{to}}} + {\sQueue, \sQueue'} + {\sBlacklist} + {\sMonitors} +} \textsc{Expect} +\end{equation*} +% +\begin{equation*} +\frac{ + \sCid \text{ fresh} +\qquad + \sProcessOf(\sCid) = \sPid +}{ + \sSystem{\sCtxt{P}[\sNewChan]_\sPid} + {\sQueue} + {\sBlacklist} + {\sMonitors} +\rightarrow + \sSystem{\sCtxt{P}[\sReturn \; (\sCid^s, \sCid^r)]_\sPid} + {\sQueue} + {\sBlacklist} + {\sMonitors} +} \textsc{NewChan} +\end{equation*} + +\begin{equation*} +\frac{ +}{ + \sSystem{\sCtxt{P}[ \sSendChan \; \sCid_\mathit{to}^s \; M ]_{\sPid_\mathit{fr}}} + {\sQueue} + {\sBlacklist} + {\sMonitors} +\rightarrow + \sSystem{\sCtxt{P}[ \sReturn \; () ]_{\sPid_\mathit{fr}}} + {\sQueue \sExtend{\sBlacklist} (\sCid_\mathit{to}, \sPid_\mathit{fr}, M)} + {\sBlacklist} + {\sMonitors} +} \textsc{SendChan} +\end{equation*} + +\begin{equation*} +\frac{ + \sPid_{\mathit{fr}} \notin \sSenders(\sQueue) +}{ + \sSystem{\sCtxt{P}[ \sReceiveChan \; \sCid_\mathit{to}^r ]_{\sPid}} + {\sQueue, (\sCid_\mathit{to}, \sPid_\mathit{fr}, M), \sQueue'} + {\sBlacklist} + {\sMonitors} +\rightarrow + \sSystem{\sCtxt{P}[ \sReturn \; M ]_{\sPid}} + {\sQueue, \sQueue'} + {\sBlacklist} + {\sMonitors} +} \textsc{ReceiveChan} +\end{equation*} +% +\begin{equation*} +\frac{ + \sRef \text{ fresh} +}{ + \sSystem{\sCtxt{P}[ \sSpawn \; \sNid \; M ]_\sPid} + {\sQueue} + {\sBlacklist} + {\sMonitors} +\rightarrow + \sSystem{\sCtxt{P}[ \sReturn \; \sRef ]_\sPid} + {\sQueue \sExtend{\sBlacklist} (\sNid, \sPid, \sSpawn \; \sRef \; M)} + {\sBlacklist} + {\sMonitors} +} \textsc{Spawn-Async} +\end{equation*} +% +\begin{equation*} +\frac{ + \sPid \notin \sSenders(\sQueue) +\qquad + \sPid' \text{ fresh} +\qquad + \sNodeOf(\sPid') = \sNid +}{ + \sSystem{\sProcesses} + {\sQueue, (\sNid, \sPid, \sSpawn \; \sRef \; M), \sQueue'} + {\sBlacklist} + {\sMonitors} +\rightarrow + \sSystem{\sProcesses \sPar M_{\sPid'}} + {\sQueue, \sQueue' \sExtend{\sBlacklist} (\sPid, \sNid, \sSpawned \; \sRef \; \sPid')} + {\sBlacklist} + {\sMonitors} +} \textsc{Spawn-Exec} +\end{equation*} +% +where +% +\begin{equation*} +\begin{array}{l@{\;=\;}l@{\hspace{3em}}l} + \sQueue \sExtend{\sBlacklist} (\sId_\mathit{to}, \sId_\mathit{fr}, M) +& + \sQueue, (\sId_\mathit{to}, \sId_\mathit{fr}, M) +& + \text{if } (\sId_\mathit{to}, \sId_\mathit{fr}) \notin \sBlacklist +\\ + \sQueue \sExtend{\sBlacklist} (\sId_\mathit{to}, \sId_\mathit{fr}, M) +& + \sQueue +& + \text{otherwise} +\end{array} +\end{equation*} +% +$(\sExtend{\sBlacklist})$ is only defined for serializable payloads. +\caption{\label{fig:basic}Basic Primitives} +\end{figure} + +\subsection{Monitoring} + +When process $P$ on node $\sNid_P$ wants to monitor process $Q$ on node +$\sNid_Q$ \emph{both} nodes must be notified. The local node it notified +immediately, and a message is sent to to the remote node (rules +\textsc{Mon-Loc} and \textsc{Mon-Rem}). As with all messages, the +message to the remote node might be lost. When $P$ is disconnected from $Q$ it +is the responsibility of $P$'s local node $\sNid_P$ to notify $P$ +(\textsc{Mon-Dis}); when $Q$ terminates (\textsc{Mon-Ret}) or crashes +(\textsc{Mon-Throw}) it is the responsibility of the remote node $\sNid_Q$ to +notify $P$. + +\begin{figure} +\small +\begin{equation*} +\frac{ + \sNid_\mathit{fr} = \sNodeOf(\sPid_\mathit{fr}) +\qquad + \sNid_\mathit{to} = \sNodeOf(\sId_\mathit{to}) +\qquad + \sRef \text{ fresh} +}{ +\sSystem{\sCtxt{P}[ \sMonitor \; \sId_\mathit{to} ]_{\sPid_\mathit{fr}}} + {\sQueue} + {\sBlacklist} + {\sMonitors} +\rightarrow + \sSystem{\sCtxt{P}[ \sReturn \; \sRef ]_{\sPid_\mathit{fr}}} + {\sQueue \sExtend{\sBlacklist} (\sNid_\mathit{to}, \sPid_\mathit{fr}, \sMonitor \; \sRef \; \sId_\mathit{to})} + {\sBlacklist} + {\sMonitors, (\sId_\mathit{to}, \sPid_\mathit{fr}, \sNid_\mathit{fr}, \sRef)} +} \textsc{Mon-Loc} +\end{equation*} +% +\begin{equation*} +\frac{ + \sPid_\mathit{fr} \notin \sSenders(\sQueue) +}{ + \sSystem{\sProcesses} + {\sQueue, (\sNid_\mathit{to}, \sPid_\mathit{fr}, \sMonitor \; \sRef \; \sId_\mathit{to}), \sQueue'} + {\sBlacklist} + {\sMonitors} +\rightarrow + \sSystem{\sProcesses} + {\sQueue, \sQueue'} + {\sBlacklist} + {\sMonitors, (\sId_\mathit{to}, \sPid_\mathit{fr}, \sNid_\mathit{to}, \sRef)} +} \textsc{Mon-Rem} +\end{equation*} +% +\begin{equation*} +\frac{ + \sNid_\mathit{fr} = \sNodeOf(\sPid_\mathit{fr}) +\qquad + (\sId_\mathit{to}, \sPid_\mathit{fr}) \in \sBlacklist +}{ + \sSystem{\sProcesses} + {\sQueue} + {\sBlacklist} + {\sMonitors, (\sId_\mathit{to}, \sPid_\mathit{fr}, \sNid_\mathit{fr}, \sRef)} +\rightarrow + \sSystem{\sProcesses} + {\sQueue, (\sPid_\mathit{fr}, \sId_\mathit{to}, \mathtt{discon} \; \sRef)} + {\sBlacklist} + {\sMonitors} +} \textsc{Mon-Dis} +\end{equation*} +% +\begin{equation*} +\frac{ + \sNodeOf(\sPid) = \sNid +}{ + \sSystem{{(\sReturn \; ())}_\sPid \sPar \sProcesses} + {\sQueue} + {\sBlacklist} + {\sMonitors, (\sPid, \sPid', \sNid, \sRef)} +\rightarrow + \sSystem{{(\sReturn \; ())}_\sPid \sPar \sProcesses} + {\sQueue \sExtend{\sBlacklist} (\sPid', \sNid, \mathtt{died} \; \sRef)} + {\sBlacklist} + {\sMonitors} +} \textsc{Mon-Ret} +\end{equation*} +% +\begin{equation*} +\frac{ + \sNodeOf(\sPid) = \sNid +}{ + \sSystem{{(\sThrow{M})}_\sPid \sPar \sProcesses} + {\sQueue} + {\sBlacklist} + {\sMonitors, (\sPid, \sPid', \sNid, \sRef)} +\rightarrow + \sSystem{{(\sThrow{M})}_\sPid \sPar \sProcesses} + {\sQueue \sExtend{\sBlacklist} (\sPid', \sNid, \mathtt{exc} \; \sRef \; M)} + {\sBlacklist} + {\sMonitors} +} \textsc{Mon-Throw} +\end{equation*} +% +\begin{equation*} +\frac{ + \sNodeOf(\sPid) = \sNid +\qquad + \sPid \notin \sProcesses +}{ + \sSystem{\sProcesses} + {\sQueue} + {\sBlacklist} + {\sMonitors, (\sPid, \sPid', \sNid, \sRef)} +\rightarrow + \sSystem{\sProcesses} + {\sQueue \sExtend{\sBlacklist} (\sPid', \sNid, \mathtt{unknown} \; \sRef)} + {\sBlacklist} + {\sMonitors} +} \textsc{Mon-Unknown} +\end{equation*} +% +\caption{Monitoring} +\end{figure} + +\subsection{Process Termination} + +The rules for normal and abnormal process termination are defined in +Figure~\ref{fig:termination}. When a process crashes it dies +silently, unless monitors are setup. + +\begin{figure} +\small +% +\begin{equation*} +\frac{ + \sNodeOf(\sPid) = \sNid +\qquad + \nexists \; \sPid', \sRef \cdot (\sPid', \sPid, \sNid, \sRef) \in \sMonitors +}{ + \sSystem{{(\sReturn \; ())}_\sPid \sPar \sProcesses} + {\sQueue} + {\sBlacklist} + {\sMonitors} +\rightarrow + \sSystem{\sProcesses} + {\sQueue} + {\sBlacklist} + {\sMonitors} +} \textsc{TermRet} +\end{equation*} +% +\begin{equation*} +\frac{ + \sNodeOf(\sPid) = \sNid +\qquad + \nexists \; \sPid', \sRef \cdot (\sPid', \sPid, \sNid, \sRef) \in \sMonitors +}{ + \sSystem{{(\sThrow{M})}_\sPid \sPar \sProcesses} + {\sQueue} + {\sBlacklist} + {\sMonitors} +\rightarrow + \sSystem{\sProcesses} + {\sQueue} + {\sBlacklist} + {\sMonitors} +} \textsc{TermThrow} +\end{equation*} +% +\caption{\label{fig:termination}Process Termination} +\end{figure} + +\section{Open Issues} + +\subsection{Ordering of Monitor/Link Notifications} + +The semantics as described above, like the original Unified semantics, does not +guarantee that messages send from process $P$ to process $Q$ (\textsc{Send}) +are ordered with respect to the link or monitor notification sent when process +$P$ terminates normally or abnormally (\textsc{Mon-Ret}, \textsc{Mon-Throw}). This means that if process $P$ does + +\begin{lstlisting} +receiveWait [ + match $ \(Reply reply) -> ... + , match $ \(ProcessMonitorNotification ..) -> ... + ] +\end{lstlisting} + +and process $Q$ does + +\begin{lstlisting} +send pidA (Reply reply) +// terminate or indeed throw an exception +\end{lstlisting} + +then the semantics does not guarantee that the reply from process $Q$ will +arrive at process $P$ before the monitor notification; hence, this results in +an (artificial) race condition in process $P$. + +One possible solution is to regard such a link notification as a message from +process $Q$ to process $P$, which should be ordered along with the other +messages. + +\subsection{Ordering and Typed Channels} + +The situation is more tricky still than sketched above because we of typed +channels. The semantics does not provide ordering guarantees between messages +sent directly to the process and messages sent on typed channels. That means +that even if we consider a link or monitor notification as a message sent to +the process, to be ordered with other messages sent to that process, it is +still unordered with respect to messages sent on typed channels. This means +that we have similar race conditions\footnote{Even ignoring the fact that we +currently don't even provide a way to wait for a message on a typed channel +\emph{or} a direct message.} + +A possible solution is to insist that \emph{all} messages from process $P$ to +process $Q$ are ordered, no matter how they are sent. From a implementation +point of view, this would entail the use of a single ordered network connection +for all messages from $P$ to $Q$, rather than using an ordered connection per +typed channel plus one for direct messages. + +\bibliographystyle{apalike} +\bibliography{references} + +\end{document} diff --git a/website/semantics/Makefile b/website/semantics/Makefile new file mode 100644 index 00000000..1f553a28 --- /dev/null +++ b/website/semantics/Makefile @@ -0,0 +1,11 @@ +CloudHaskellSemantics.pdf: *.tex *.bib + pdflatex CloudHaskellSemantics + bibtex CloudHaskellSemantics + pdflatex CloudHaskellSemantics + pdflatex CloudHaskellSemantics + +.PHONY: clean +clean: + rm -f *.aux *.bbl *.blg *.log + +# vi:set noexpandtab: diff --git a/website/semantics/references.bib b/website/semantics/references.bib new file mode 100644 index 00000000..0ac0c680 --- /dev/null +++ b/website/semantics/references.bib @@ -0,0 +1,72 @@ +@inproceedings{cloudhaskell, + author = {Epstein, Jeff and Black, Andrew P. and Peyton-Jones, Simon}, + title = {Towards {H}askell in the cloud}, + booktitle = {Proceedings of the 4th ACM symposium on Haskell}, + series = {Haskell '11}, + year = {2011}, + isbn = {978-1-4503-0860-1}, + location = {Tokyo, Japan}, + pages = {118--129}, + numpages = {12}, + url = {http://doi.acm.org/10.1145/2034675.2034690}, + doi = {10.1145/2034675.2034690}, + acmid = {2034690}, + publisher = {ACM}, + address = {New York, NY, USA}, + keywords = {erlang, haskell, message-passing}, +} + +@inproceedings{unified, + author = {Svensson, Hans and Fredlund, Lars-{\AA}ke and Benac Earle, Clara}, + title = {A unified semantics for future {E}rlang}, + booktitle = {Proceedings of the 9th ACM SIGPLAN workshop on Erlang}, + series = {Erlang '10}, + year = {2010}, + isbn = {978-1-4503-0253-1}, + location = {Baltimore, Maryland, USA}, + pages = {23--32}, + numpages = {10}, + url = {http://doi.acm.org/10.1145/1863509.1863514}, + doi = {10.1145/1863509.1863514}, + acmid = {1863514}, + publisher = {ACM}, + address = {New York, NY, USA}, + keywords = {erlang, semantics}, +} + +@article{stm, + author = {Harris, Tim and Marlow, Simon and Jones, Simon Peyton and Herlihy, Maurice}, + title = {Composable memory transactions}, + journal = {Commun. ACM}, + issue_date = {August 2008}, + volume = {51}, + number = {8}, + month = aug, + year = {2008}, + issn = {0001-0782}, + pages = {91--100}, + numpages = {10}, + url = {http://doi.acm.org/10.1145/1378704.1378725}, + doi = {10.1145/1378704.1378725}, + acmid = {1378725}, + publisher = {ACM}, + address = {New York, NY, USA}, +} + +@inproceedings{erlang, + author = {Svensson, Hans and Fredlund, Lars-\AAke}, + title = {A more accurate semantics for distributed erlang}, + booktitle = {Proceedings of the 2007 SIGPLAN workshop on ERLANG Workshop}, + series = {ERLANG '07}, + year = {2007}, + isbn = {978-1-59593-675-2}, + location = {Freiburg, Germany}, + pages = {43--54}, + numpages = {12}, + url = {http://doi.acm.org/10.1145/1292520.1292528}, + doi = {10.1145/1292520.1292528}, + acmid = {1292528}, + publisher = {ACM}, + address = {New York, NY, USA}, + keywords = {distributed systems, erlang, model checking, semantics, verification}, +} diff --git a/website/static/semantics.pdf b/website/static/semantics.pdf new file mode 100644 index 00000000..6f01eb85 Binary files /dev/null and b/website/static/semantics.pdf differ diff --git a/website/static/templates/wikipage.mdt b/website/static/templates/wikipage.mdt new file mode 100644 index 00000000..c0ff0d00 --- /dev/null +++ b/website/static/templates/wikipage.mdt @@ -0,0 +1,10 @@ +--- +layout: wiki +title: @PAGE@ +wiki: @PAGE@ +--- + +### @PAGE@ + +Content goes here. See https://github.com/mojombo/jekyll for further +instructions. diff --git a/website/static/tutorial/tutorial-client.hs b/website/static/tutorial/tutorial-client.hs new file mode 100644 index 00000000..a3acd5fd --- /dev/null +++ b/website/static/tutorial/tutorial-client.hs @@ -0,0 +1,25 @@ +import Network.Transport +import Network.Transport.TCP (createTransport, defaultTCPParameters) +import Network.Socket.Internal (withSocketsDo) +import System.Environment +import Control.Monad +import Data.ByteString.Char8 + +main :: IO () +main = withSocketsDo $ do + [host, port, serverAddr] <- getArgs + Right transport <- createTransport host port defaultTCPParameters + Right endpoint <- newEndPoint transport + + let addr = EndPointAddress (pack serverAddr) +-- Right conn <- connect endpoint addr ReliableOrdered defaultConnectHints + x <- connect endpoint addr ReliableOrdered defaultConnectHints + let conn = case x of + Right conn -> conn + Left err -> error$ "Error connecting: "++show err + send conn [pack "Hello world"] + close conn + + replicateM_ 3 $ receive endpoint >>= print + + closeTransport transport diff --git a/website/static/tutorial/tutorial-server.hs b/website/static/tutorial/tutorial-server.hs new file mode 100644 index 00000000..68e318d9 --- /dev/null +++ b/website/static/tutorial/tutorial-server.hs @@ -0,0 +1,55 @@ +import Network.Transport +import Network.Transport.TCP (createTransport, defaultTCPParameters) +import Network.Socket.Internal (withSocketsDo) +import Control.Concurrent +import Data.Map +import Control.Exception +import System.Environment + +-- | Server that echoes messages straight back to the origin endpoint. +echoServer :: EndPoint -> MVar () -> IO () +echoServer endpoint serverDone = go empty + where + go :: Map ConnectionId (MVar Connection) -> IO () + go cs = do + event <- receive endpoint + case event of + ConnectionOpened cid rel addr -> do + putStrLn$ " New connection: ID "++show cid++", reliability: "++show rel++", address: "++ show addr + connMVar <- newEmptyMVar + forkIO $ do + Right conn <- connect endpoint addr rel defaultConnectHints + putMVar connMVar conn + go (insert cid connMVar cs) + Received cid payload -> do + forkIO $ do + conn <- readMVar (cs ! cid) + send conn payload + return () + go cs + ConnectionClosed cid -> do + putStrLn$ " Closed connection: ID "++show cid + forkIO $ do + conn <- readMVar (cs ! cid) + close conn + go (delete cid cs) + EndPointClosed -> do + putStrLn "Echo server exiting" + putMVar serverDone () + +onCtrlC :: IO a -> IO () -> IO a +p `onCtrlC` q = catchJust isUserInterrupt p (const $ q >> p `onCtrlC` q) + where + isUserInterrupt :: AsyncException -> Maybe () + isUserInterrupt UserInterrupt = Just () + isUserInterrupt _ = Nothing + +main :: IO () +main = withSocketsDo $ do + [host, port] <- getArgs + serverDone <- newEmptyMVar + Right transport <- createTransport host port defaultTCPParameters + Right endpoint <- newEndPoint transport + forkIO $ echoServer endpoint serverDone + putStrLn $ "Echo server started at " ++ show (address endpoint) + readMVar serverDone `onCtrlC` closeTransport transport diff --git a/website/team.md b/website/team.md new file mode 100644 index 00000000..924776e7 --- /dev/null +++ b/website/team.md @@ -0,0 +1,63 @@ +--- +layout: team +title: Cloud Haskell Team +--- + +### Origins + +Cloud Haskell was originally the brainchild of Jeff Epstein, Simon Peyton Jones +and Dr Andrew Black, whose joint paper for the Tokyo Haskell Symposium +[Towards Haskell in the Cloud][1], was expanded in Epstein's 2011 masters thesis +[Functional programming for the data centre][2]. + +[Jeff] [7] wrote the original implementation of Cloud Haskell, which is still +available in the published [remote package][3]. + +### Well Typed + +[Well-Typed][4] is a consultancy specialising in Haskell/GHC development. A team +of developers from Well-Typed rewrote Jeff's [remote][3] package from the ground +up as part of the [Parallel Haskell Project][5]. Well-Typed remain closely involved +in Cloud Haskell. + +### Maintainers + +[Tim Watson][6] and [Jeff Epstein][7] are currently the [official maintainers][9] +of Cloud Haskell as a whole. [Edsko De Vries][13], a member of Well-Typed and the +author of much of the new implementation we have today, is still closely involved +as well. + +Most of the packages are maintained by the haskell-distributed +organization, with people from Well Typed, Tweag, and other companies +that are involved. + +The core [disributed-process][8] library is maintained by +[Facundo Domínguez][14], and the platform libaries are maintained by +[Tim Watson][6]. + +Some libraries are maintained my third parties, most notably d-p-p2p. + +[Jeff][7] is the author of [distributed-process-global][11], a re-implementation of +Erlang's [global][12] (locking, registration and cluster management) API for +Cloud Haskell. + +A number of other community members have contributed to the new implementation, +in various ways - here are at least some of them: + +Duncan Coutts, Simon Marlow, Ryan Newton, Eric Kow, Adam Foltzer, Nicolas Wu +@rodlogic (github), Takayuki Muranushi, Alen Ribic, Pankaj More, Mark Wright + +[1]: http://research.microsoft.com/en-us/um/people/simonpj/papers/parallel/remote.pdf +[2]: http://research.microsoft.com/en-us/um/people/simonpj/papers/parallel/epstein-thesis.pdf +[3]: http://hackage.haskell.org/package/remote-0.1.1 +[4]: http://www.well-typed.com +[5]: http://www.haskell.org/haskellwiki/Parallel_GHC_Project +[6]: https://github.com/hyperthunk +[7]: https://github.com/jepst +[8]: https://github.com/haskell-distributed/disributed-process +[9]: http://hackage.haskell.org/trac/ghc/wiki/Contributors +[10]: http://en.wikipedia.org/wiki/Open_Telecom_Platform +[11]: https://github.com/jepst/distributed-process-global +[12]: http://www.erlang.org/doc/man/global.html +[13]: https://github.com/edsko +[14]: https://github.com/facundominguez diff --git a/website/terms.md b/website/terms.md new file mode 100644 index 00000000..40c8f2af --- /dev/null +++ b/website/terms.md @@ -0,0 +1,6 @@ +--- +layout: page +title: Terms +--- + +http://creativecommons.org/licenses/by-sa/3.0/ diff --git a/website/tutorials/1ch.md b/website/tutorials/1ch.md new file mode 100644 index 00000000..4eb07d27 --- /dev/null +++ b/website/tutorials/1ch.md @@ -0,0 +1,297 @@ +--- +layout: tutorial +categories: tutorial +sections: ['Getting Started', 'Creating a node', 'Sending messages', 'Spawning Remote Processes'] +title: 1. Getting Started +--- + +### Getting Started + +----- + +In order to go through this tutorial, you will need a working Haskell +environment. If you don't already have one follow the instructions +[here](https://www.haskell.org/downloads) to install the compiler and +then +[go here](https://github.com/commercialhaskell/stack/wiki/Downloads) +to install `stack`, a popular build tool for Haskell projects. + +Once you're up and running, you'll want to get hold of the +`distributed-process` library and a choice of network transport +backend. This guide will use the `network-transport-tcp` backend, but +other backends are available on [Hackage](https://hackage.haskell.org) +and [GitHub](https://github.com). + +### Setting up the project + +Starting a new Cloud Haskell project using `stack` is as easy as + +{% highlight bash %} +$ stack new +{% endhighlight %} + +in a fresh new directory. This will populate the directory with +a number of files, chiefly `stack.yaml` and `*.cabal` metadata files +for the project. You'll want to add `distributed-process` and +`network-transport-tcp` to the `build-depends` stanza of the +executable section. + +### Creating a node + +Cloud Haskell's *lightweight processes* reside on a "node", which must +be initialised with a network transport implementation and a remote table. +The latter is required so that physically separate nodes can identify known +objects in the system (such as types and functions) when receiving messages +from other nodes. We will look at inter-node communication later, for now +it will suffice to pass the default remote table, which defines the built-in +types that Cloud Haskell needs at a minimum in order to run. + +In `app/Main.hs`, we start with our imports: + +{% highlight haskell %} +import Network.Transport.TCP (createTransport, defaultTCPParameters) +import Control.Distributed.Process +import Control.Distributed.Process.Node +{% endhighlight %} + +Our TCP network transport backend needs an IP address and port to get started +with: + +{% highlight haskell %} +main :: IO () +main = do + Right t <- createTransport "127.0.0.1" "10501" defaultTCPParameters + node <- newLocalNode t initRemoteTable + .... +{% endhighlight %} + +And now we have a running node. + +### Sending messages + +We start a new process by evaluating `runProcess`, which takes a node and +a `Process` action to run, because our concurrent code will run in the +`Process` monad. Each process has an identifier associated to it. The process +id can be used to send messages to the running process - here we will send one +to ourselves! + +{% highlight haskell %} +-- in main + _ <- runProcess node $ do + -- get our own process id + self <- getSelfPid + send self "hello" + hello <- expect :: Process String + liftIO $ putStrLn hello + return () +{% endhighlight %} + +Note that we haven't deadlocked our own thread by sending to and receiving +from its mailbox in this fashion. Sending messages is a completely +asynchronous operation - even if the recipient doesn't exist, no error will be +raised and evaluating `send` will not block the caller, even if the caller is +sending messages to itself. + +Each process also has a *mailbox* associated with it. Messages sent to +a process are queued in this mailbox. A process can pop a message out of its +mailbox using `expect` or the `receive*` family of functions. If no message of +the expected type is in the mailbox currently, the process will block until +there is. Messages in the mailbox are ordered by time of arrival. + +Let's spawn two processes on the same node and have them talk to each other: + +{% highlight haskell %} +import Control.Concurrent (threadDelay) +import Control.Monad (forever) +import Control.Distributed.Process +import Control.Distributed.Process.Node +import Network.Transport.TCP (createTransport, defaultTCPParameters) + +replyBack :: (ProcessId, String) -> Process () +replyBack (sender, msg) = send sender msg + +logMessage :: String -> Process () +logMessage msg = say $ "handling " ++ msg + +main :: IO () +main = do + Right t <- createTransport "127.0.0.1" "10501" defaultTCPParameters + node <- newLocalNode t initRemoteTable + runProcess node $ do + -- Spawn another worker on the local node + echoPid <- spawnLocal $ forever $ do + -- Test our matches in order against each message in the queue + receiveWait [match logMessage, match replyBack] + + -- The `say` function sends a message to a process registered as "logger". + -- By default, this process simply loops through its mailbox and sends + -- any received log message strings it finds to stderr. + + say "send some messages!" + send echoPid "hello" + self <- getSelfPid + send echoPid (self, "hello") + + -- `expectTimeout` waits for a message or times out after "delay" + m <- expectTimeout 1000000 + case m of + -- Die immediately - throws a ProcessExitException with the given reason. + Nothing -> die "nothing came back!" + Just s -> say $ "got " ++ s ++ " back!" + + -- Without the following delay, the process sometimes exits before the messages are exchanged. + liftIO $ threadDelay 2000000 +{% endhighlight %} + +Note that we've used `receiveWait` this time around to get a message. +`receiveWait` and similarly named functions can be used with the +[`Match` data type][5] to provide a range of advanced message +processing capabilities. The `match` primitive allows you to construct +a "potential message handler" and have it evaluated against received +(or incoming) messages. Think of a list of `Match`es as the +distributed equivalent of a pattern match. As with `expect`, if the +mailbox does not contain a message that can be matched, the evaluating +process will be blocked until a message arrives which _can_ be +matched. + +In the _echo server_ above, our first match prints out whatever string it +receives. If the first message in our mailbox is not a `String`, then our +second match is evaluated. Thus, given a tuple `t :: (ProcessId, String)`, it +will send the `String` component back to the sender's `ProcessId`. If neither +match succeeds, the echo server blocks until another message arrives and tries +again. + +### Serializable Data + +Processes may send any datum whose type implements the `Serializable` +typeclass, defined as: + +{% highlight haskell %} +class (Binary a, Typeable) => Serializable a +instance (Binary a, Typeable a) => Serializable a +{% endhighlight %} + +That is, any type that is `Binary` and `Typeable` is `Serializable`. This is +the case for most of Cloud Haskell's primitive types as well as many standard +data types. For custom data types, the `Typeable` instance is always +given by the compiler, and the `Binary` instance can be auto-generated +too in most cases, e.g.: + +{% highlight haskell %} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} + +data T = T Int Char deriving (Generic, Typeable) + +instance Binary T +{% endhighlight %} + + +### Spawning Remote Processes + +We saw above that the behaviour of processes is determined by an action in the +`Process` monad. However, actions in the `Process` monad, no more serializable +than actions in the `IO` monad. If we can't serialize actions, then how can we +spawn processes on remote nodes? + +The solution is to consider only *static* actions and compositions thereof. +A static action is always defined using a closed expression (intuitively, an +expression that could in principle be evaluated at compile-time since it does +not depend on any runtime arguments). The type of static actions in Cloud +Haskell is `Closure (Process a)`. More generally, a value of type `Closure b` +is a value that was constructed explicitly as the composition of symbolic +pointers and serializable values. Values of type `Closure b` are serializable, +even if values of type `b` might not be. For instance, while we can't in general +send actions of type `Process ()`, we can construct a value of type `Closure +(Process ())` instead, containing a symbolic name for the action, and send +that instead. So long as the remote end understands the same meaning for the +symbolic name, this works just as well. A remote spawn then, takes a static +action and sends that across the wire to the remote node. + +Static actions are not easy to construct by hand, but fortunately Cloud +Haskell provides a little bit of Template Haskell to help. If `f :: T1 -> T2` +then + +{% highlight haskell %} + $(mkClosure 'f) :: T1 -> Closure T2 +{% endhighlight %} + +You can turn any top-level unary function into a `Closure` using `mkClosure`. +For curried functions, you'll need to uncurry them first (i.e. "tuple up" the +arguments). However, to ensure that the remote side can adequately interpret +the resulting `Closure`, you'll need to add a mapping in a so-called *remote +table* associating the symbolic name of a function to its value. Processes can +only be successfully spawned on remote nodes if all these remote nodes have +the same remote table as the local one. + +We need to configure our remote table (see the [API reference][6] for +more details) and the easiest way to do this, is to let the library +generate the relevant code for us. For example: + +{% highlight haskell %} +sampleTask :: (TimeInterval, String) -> Process () +sampleTask (t, s) = sleep t >> say s + +remotable ['sampleTask] +{% endhighlight %} + +The last line is a top-level Template Haskell splice. At the call site for +`spawn`, we can construct a `Closure` corresponding to an application of +`sampleTask` like so: + +{% highlight haskell %} +($(mkClosure 'sampleTask) (seconds 2, "foobar")) +{% endhighlight %} + +The call to `remotable` implicitly generates a remote table by inserting +a top-level definition `__remoteTable :: RemoteTable -> RemoteTable` in our +module for us. We compose this with other remote tables in order to come up +with a final, merged remote table for all modules in our program: + +{% highlight haskell %} +{-# LANGUAGE TemplateHaskell #-} + +import Control.Concurrent (threadDelay) +import Control.Monad (forever) +import Control.Distributed.Process +import Control.Distributed.Process.Closure +import Control.Distributed.Process.Node +import Network.Transport.TCP (createTransport, defaultTCPParameters) + +sampleTask :: (Int, String) -> Process () +sampleTask (t, s) = liftIO (threadDelay (t * 1000000)) >> say s + +remotable ['sampleTask] + +myRemoteTable :: RemoteTable +myRemoteTable = Main.__remoteTable initRemoteTable + +main :: IO () +main = do + Right transport <- createTransport "127.0.0.1" "10501" defaultTCPParameters + node <- newLocalNode transport myRemoteTable + runProcess node $ do + us <- getSelfNode + _ <- spawnLocal $ sampleTask (1 :: Int, "using spawnLocal") + pid <- spawn us $ $(mkClosure 'sampleTask) (1 :: Int, "using spawn") + liftIO $ threadDelay 2000000 +{% endhighlight %} + +In the above example, we spawn `sampleTask` on node `us` in two +different ways: + +* using `spawn`, which expects some node identifier to spawn a process + on along with a `Closure` for the action of the process. +* using `spawnLocal`, a specialization of `spawn` for the case when the + node identifier actually refers to the local node (i.e. `us`). In + this special case, no serialization is necessary, so passing an + action directly rather than a `Closure` works just fine. + +------ + +[1]: https://hackage.haskell.org/package/distributed-process-0.6.6/docs/Control-Distributed-Process.html#t:Message +[2]: https://hackage.haskell.org/package/distributed-process +[3]: https://hackage.haskell.org/package/distributed-process-async/docs/Control-Distributed-Process-Async.html +[4]: https://hackage.haskell.org/package/distributed-process-client-server-0.1.3.2/docs/Control-Distributed-Process-ManagedProcess-Client.html#v:callAsync +[5]: https://hackage.haskell.org/packages/archive/distributed-process/latest/doc/html/Control-Distributed-Process-Internal-Primitives.html#t:Match +[6]: https://hackage.haskell.org/packages/archive/distributed-process/latest/doc/html/Control-Distributed-Process-Closure.html diff --git a/website/tutorials/2ch.md b/website/tutorials/2ch.md new file mode 100644 index 00000000..dbf36158 --- /dev/null +++ b/website/tutorials/2ch.md @@ -0,0 +1,111 @@ +--- +layout: tutorial +categories: tutorial +sections: ['Overview', 'A Simple Example', 'Master Slave Configurations', 'Other Topologies and Backends'] +title: 2. Managing Topologies +--- + +### Overview + +In Cloud Haskell, the system topology is determined by your choice of _Cloud Haskell Backend_. +The basic topology that Cloud Haskell currently ships with is determined by the +[`simplelocalnet`][1] backend, which provides for a fully connected grid of nodes with optional +master-slave configuration. This backend allows nodes to discover one another using UDP multicast. +It is a zero-configuration backend designed to get you going with Cloud Haskell quickly without +imposing any particular structure on your application. + +Other backends might work in a completely different manner, offering different types of (and +relationships between) nodes, or simply by handling discovery differently (e.g., pre-defined +node names/addresses, or by using some form of registrar such as DNS-SD/Bonjour). + +### A Simple Example + +Here is an example program built against the [`simplelocalnet`][1] backend, that periodically +searches for a list of peer nodes, and sends a message to a registered (named) process on each. + +{% highlight haskell %} +import System.Environment (getArgs) +import Control.Distributed.Process +import Control.Distributed.Process.Node (initRemoteTable, runProcess) +import Control.Distributed.Process.Backend.SimpleLocalnet +import Control.Monad (forever, forM_) + +main = do + [host, port] <- getArgs + + backend <- initializeBackend host port initRemoteTable + node <- newLocalNode backend + peers <- findPeers backend 1000000 + runProcess node $ forM_ peers $ \peer -> nsendRemote peer "echo-server" "hello!" + +{% endhighlight %} + +Clearly the program isn't very useful, but it illustrates the two key concepts that +`simplelocalnet` relies on. Firstly, that we `initializeBackend` in order to get +connected to an underlying communications infrastructure and secondly, that we can +evaluate `findPeers` at any time to obtain the set of other nodes that have broadcast +their presence. + +### Master Slave Configurations + +Here we simply rehash the master/slave example from the `simplelocalnet` documentation. +With the same imports as the example above, we add a no-op slave and a master that +takes a list of its (known) slaves, which it prints out before terminating them all. + +{% highlight haskell %} +main :: IO () +main = do + args <- getArgs + + case args of + ["master", host, port] -> do + backend <- initializeBackend host port initRemoteTable + startMaster backend (master backend) + ["slave", host, port] -> do + backend <- initializeBackend host port initRemoteTable + startSlave backend + +{% endhighlight %} + +And the master node is defined thus: + +{% highlight haskell %} +master :: Backend -> [NodeId] -> Process () +master backend slaves = do + -- Do something interesting with the slaves + liftIO . putStrLn $ "Slaves: " ++ show slaves + -- Terminate the slaves when the master terminates (this is optional) + terminateAllSlaves backend +{% endhighlight %} + +### Other Topologies and Backends + +Many other topologies are in development, including one that runs on Windows Azure, +which is available [here][2]. Some third party backends have also been developed, +such as the [`distributed-process-p2p`][3] backend, which given a known node address, +discovers and maintains knowledge of it's peers. + +Here is an example of node discovery using the [`distributed-process-p2p`][3] +backend: + +{% highlight haskell %} +import System.Environment (getArgs) +import Control.Distributed.Process +import Control.Distributed.Process.Node (initRemoteTable) +import Control.Distributed.Process.Backend.P2P +import Control.Monad (forever, mapM_) + +main = do + [host, port] <- getArgs + + backend <- initializeBackend host port initRemoteTable + node <- newLocalNode backend + runProcess node $ forever $ do + findPeers >>= mapM_ $ \peer -> nsend peer "echo-server" "hello!" + +{% endhighlight %} + +[1]: http://hackage.haskell.org/package/distributed-process-simplelocalnet +[2]: http://hackage.haskell.org/package/distributed-process-azure +[3]: https://bitbucket.org/dpwiz/distributed-process-p2p + diff --git a/website/tutorials/3ch.md b/website/tutorials/3ch.md new file mode 100644 index 00000000..175dda65 --- /dev/null +++ b/website/tutorials/3ch.md @@ -0,0 +1,558 @@ +--- +layout: tutorial +categories: tutorial +sections: ['Message Ordering', 'Selective Receive', 'Advanced Mailbox Processing', 'Typed Channels', 'Process Lifetime', 'Monitoring And Linking', 'Getting Process Info','Monad Transformer Stacks' ] +title: 3. Getting to know Processes +--- + +### Message Ordering + +We have already met the `send` primitive, used to deliver messages from one +process to another. Here's a review of what we've learned about `send` thus far: + +1. sending is asynchronous (i.e., it does not block the caller) +2. sending _never_ fails, regardless of the state of the recipient process +3. even if a message is received, there is **no** guarantee *when* it will arrive +4. there are **no** guarantees that the message will be received at all + +Asynchronous sending buys us several benefits. Improved concurrency is +possible, because processes need not block or wait for acknowledgements, +nor does error handling need to be implemented each time a message is sent. +Consider a stream of messages sent from one process to another. If the +stream consists of messages `a, b, c` and we have seen `c`, then we know for +certain that we will have already seen `a, b` (in that order), so long as the +messages were sent to us by the same peer process. + +When two concurrent process exchange messages, Cloud Haskell guarantees that +messages will be delivered in FIFO order, if at all. No such guarantee exists +between N processes where N > 1, so if processes _A_ and _B_ are both +communicating (concurrently) with process _C_, the ordering guarantee will +only hold for each pair of interactions, i.e., between _A_ and _C_ and/or +_B_ and _C_ the ordering will be guaranteed, but not between _A_ and _B_ +with regards messages sent to _C_. + +Because the mailbox contains messages of varying types, when we `expect` +a message, we eschew the ordering because we're searching for a message +whose contents can be decoded to a specific type. Of course, we may _want_ +to process messages in the precise order which they arrived. To achieve +this, we must defer the type checking that would normally cause a traversal +of the mailbox and extract the _raw_ message ourselves. This can be achieved +using `receive` and `matchAny`, as we will demonstrate later. + +### Selective Receive + +Processes dequeue messages (from their mailbox) using the [`expect`][1] +and [`receive`][2] family of primitives. Both take an optional timeout, +allowing the expression to evaluate to `Nothing` if no matching input +is found. + +The [`expect`][1] primitive blocks until a message matching the expected type +(of the expression) is found in the process' mailbox. If a match is found by +scanning the mailbox, it is dequeued and returned, otherwise the caller +(i.e., the calling thread/process) is blocked until a message of the expected +type is delivered to the mailbox. Let's take a look at this in action: + +{% highlight haskell %} +demo :: Process () +demo = do + listener <- spawnLocal listen + send listener "hello" + getSelfPid >>= send listener + () <- expect + return () + where + listen = do + third <- expect :: Process ProcessId + first <- expect :: Process String + second <- expectTimeout 100000 :: Process (Maybe String) + (say . show) first + (say . show) second + (say . show) third + send third () +{% endhighlight %} + +This program will print `"hello"`, then `Nothing` and finally `pid://...`. +The first `expect` - labelled "third" because of the order in which we +know it will arrive in our mailbox - **will** succeed, since the parent process +sends its `ProcessId` after the string "hello", yet the listener blocks until it +can dequeue the `ProcessId` before "expecting" a string. The second `expect` +(labelled "first") also succeeds, demonstrating that the listener has selectively +removed messages from its mailbox based on their type rather than the order in +which they arrived. The third `expect` will timeout and evaluate to `Nothing`, +because only one string is ever sent to the listener and that has already been +removed from the mailbox. The removal of messages from the process' mailbox based +on type is what makes this program viable - without this "selective receiving", +the program would block and never complete. + +By contrast, the [`receive`][2] family of primitives take a list of `Match` +objects, each derived from evaluating a [`match`][3] style primitive. This +subject was covered briefly in the first tutorial. Matching on messages allows +us to separate the type(s) of messages we can handle from the type that the +whole `receive` expression evaluates to. + +Consider the following snippet: + +{% highlight haskell %} +usingReceive = do + () <- receiveWait [ + match (\(s :: String) -> say s) + , match (\(i :: Int) -> say $ show i) + ] +{% endhighlight %} + +Note that each of the matches in the list must evaluate to the same type, +as the type signature indicates: `receiveWait :: [Match b] -> Process b`. + +The behaviour of `receiveWait` differs from `receiveTimeout` in that it +blocks forever (until a match is found in the process' mailbox), whereas the +variant taking a timeout will return `Nothing` unless a match is found within +the specified time interval. Note that as with `System.Timeout`, the only +guarantee we have about a timeout based function is that it will not +expire _before_ the given interval. Both functions scan the mailbox in FIFO +order, evaluating the list of `match` expressions in declarative +(i.e., insertion) order until one of the matches succeeds or the operation +times out. + +### Advanced Mailbox Processing + +There are times when it is desirable to take a message from our mailbox without +explicitly specifying its type. Not only is this a useful capability, it is the +_only_ way to process messages in the precise order they were received. + +To see how this works in practise, let's consider the `relay` primitive that +ships with distributed-process. This utility function starts a process that +simply dequeues _any_ messages it receives and forwards them to some other process. +In order to dequeue messages regardless of their type, this code relies on the +`matchAny` primitive, which has the following type: + +{% highlight haskell %} +matchAny :: forall b. (Message -> Process b) -> Match b +{% endhighlight %} + +Since forwarding _raw messages_ (without decoding them first) is a common pattern +in Cloud Haskell programs, there is also a primitive to do that for us: + +{% highlight haskell %} +forward :: Message -> ProcessId -> Process () +{% endhighlight %} + +Given these types, we can see that in order to combine `matchAny` with `forward` +we need to either _flip_ `forward` and apply the `ProcessId` (leaving us with +the required type `Message -> Process b`) or use a lambda - the actual implementation +does the latter and looks like this: + +{% highlight haskell %} +relay :: ProcessId -> Process () +relay !pid = forever' $ receiveWait [ matchAny (\m -> forward m pid) ] +{% endhighlight %} + +This is pretty useful, but since `matchAny` operates on the raw `Message` type, +we're limited in what we can do with the messages we receive. In order to delve +_inside_ a message, we have to know its type. If we have an expression that operates +on a specific type, we can _attempt_ to decode the message to that type and examine +the result to see whether the decoding succeeds or not. There are two primitives +we can use to that effect: `unwrapMessage` and `handleMessage`. Their types look like +this: + +{% highlight haskell %} +unwrapMessage :: forall m a. (Monad m, Serializable a) => Message -> m (Maybe a) + +handleMessage :: forall m a b. (Monad m, Serializable a) => Message -> (a -> m b) -> m (Maybe b) +{% endhighlight %} + +Of the two, `unwrapMessage` is the simpler, taking a raw `Message` and evaluating to +`Maybe a` before returning that value in the monad `m`. If the type of the raw `Message` +does not match our expectation, the result will be `Nothing`, otherwise `Just a`. + +The approach `handleMessage` takes is a bit more flexible, taking a function +from `a -> m b` and returning `Just b` if the underlying message is of type `a` (hence the +operation can be executed and evaluate to `Maybe b`) or `Nothing` if the message's type +is incompatible with the handler function. + +Let's look at `handleMessage` in action. Earlier on we looked at `relay` from +distributed-process and now we'll consider its sibling `proxy` - this takes a predicate, +evaluates some input of type `a` and returns `Process Bool`, allowing us to run arbitrary +`Process` code in order to decide whether or not the `a` is eligible to be forwarded to +the relay `ProcessId`. The type of `proxy` is thus: + +{% highlight haskell %} +proxy :: Serializable a => ProcessId -> (a -> Process Bool) -> Process () +{% endhighlight %} + +Since `matchAny` operates on `(Message -> Process b)` and `handleMessage` operates on +`a -> Process b` we can compose these to make our proxy server. We must not forward +messages for which the predicate function evaluates to `Just False`, nor can we sensibly +forward messages which the predicate function is unable to evaluate due to type +incompatibility. This leaves us with the definition found in distributed-process: + +{% highlight haskell %} +proxy pid proc = do + receiveWait [ + matchAny (\m -> do + next <- handleMessage m proc + case next of + Just True -> forward m pid + Just False -> return () -- explicitly ignored + Nothing -> return ()) -- un-routable / cannot decode + ] + proxy pid proc +{% endhighlight %} + +Beyond simple relays and proxies, the raw message handling capabilities available in +distributed-process can be utilised to develop highly generic message processing code. +All the richness of the distributed-process-client-server APIs (such as `ManagedProcess`) which +will be discussed in later tutorials are, in fact, built upon these families of primitives. + +### Typed Channels + +While being able to send and receive any `Serializable` datum is very powerful, the burden +of decoding types correctly at runtime is levied on the programmer and there are runtime +overheads to be aware of (which will be covered in later tutorials). Fortunately, +distributed-provides provides a type safe alternative to `send` and `receive`, in the form +of _Typed Channels_. Represented by distinct ends, a `SendPort a` (which is `Serializable`) +and `ReceivePort a` (which is not), channels are a lightweight and useful abstraction that +provides a type safe interface for interacting with processes separately from their primary +mailbox. + +Channels are created with `newChan :: Process (SendPort a, ReceivePort a)`, with +messages sent via `sendChan :: SendPort a -> a -> Process ()`. The `ReceivePort` can be +passed directly to `receiveChan`, or used in a `receive{Wait, Timeout}` call via the +`matchChan` primitive, so as to combine mailbox scans with channel reads. + +### Process Lifetime + +A process will continue executing until it has evaluated to some value, or is abruptly +terminated either by crashing (with an un-handled exception) or being instructed to +stop executing. Deliberate stop instructions take one of two forms: a `ProcessExitException` +or `ProcessKillException`. As the names suggest, these _signals_ are delivered in the form +of asynchronous exceptions, however you should not to rely on that fact! After all, +we cannot throw an exception to a thread that is executing in some other operating +system process or on a remote host! Instead, you should use the [`exit`][5] and [`kill`][6] +primitives from distributed-process, which not only ensure that remote target processes +are handled seamlessly, but also maintain a guarantee that if you send a message and +*then* an exit signal, the message will be delivered to the destination process (via its +local node controller) before the exception is thrown - note that this does not guarantee +that the destination process will have time to _do anything_ with the message before it +is terminated. + +The `ProcessExitException` signal is sent from one process to another, indicating that the +receiver is being asked to terminate. A process can choose to tell itself to exit, and the +[`die`][7] primitive simplifies doing so without worrying about the expected type for the +action. In fact, [`die`][7] has slightly different semantics from [`exit`][5], since the +latter involves sending an internal signal to the local node controller. A direct consequence +of this is that the _exit signal_ may not arrive immediately, since the _Node Controller_ could +be busy processing other events. On the other hand, the [`die`][7] primitive throws a +`ProcessExitException` directly in the calling thread, thus terminating it without delay. +In practise, this means the following two functions could behave quite differently at +runtime: + +{% highlight haskell %} + +-- this will never print anything... +demo1 = die "Boom" >> expect >>= say + +-- this /might/ print something before it exits +demo2 = do + self <- getSelfPid + exit self "Boom" + expect >>= say +{% endhighlight %} + +The `ProcessExitException` type holds a _reason_ field, which is serialised as a raw `Message`. +This exception type is exported, so it is possible to catch these _exit signals_ and decide how +to respond to them. Catching _exit signals_ is done via a set of primitives in +distributed-process, and the use of them forms a key component of the various fault tolerance +strategies provided by distributed-process-supervisor. + +A `ProcessKillException` is intended to be an _untrappable_ exit signal, so its type is +not exported and therefore you can __only__ handle it by catching all exceptions, which +as we all know is very bad practise. The [`kill`][6] primitive is intended to be a +_brutal_ means for terminating process - e.g., it is used to terminate supervised child +processes that haven't shutdown on request, or to terminate processes that don't require +any special cleanup code to run when exiting - although it does behave like [`exit`][5] +in so much as it is dispatched (to the target process) via the _Node Controller_. + +### Monitoring and Linking + +Processes can be linked to other processes (or nodes or channels). A link, which is +unidirectional, guarantees that once any object we have linked to *exits*, we will also +be terminated. A simple way to test this is to spawn a child process, link to it and then +terminate it, noting that we will subsequently die ourselves. Here's a simple example, +in which we link to a child process and then cause it to terminate (by sending it a message +of the type it is waiting for). Even though the child terminates "normally", our process +is also terminated since `link` will _link the lifetime of two processes together_ regardless +of exit reasons. + +{% highlight haskell %} +demo = do + pid <- spawnLocal $ expect >>= return + link pid + send pid () + () <- expect + return () +{% endhighlight %} + +The medium that link failures uses to signal exit conditions is the same as exit and kill +signals - asynchronous exceptions. Once again, it is a bad idea to rely on this (not least +because it might change in some future release) and the exception type (`ProcessLinkException`) +is not exported so as to prevent developers from abusing exception handling code in this +special case. Since link exit signals cannot be caught directly, if you find yourself wanting +to _trap_ a link failure, you probably want to use a monitor instead. + +Whilst the built-in `link` primitive terminates the link-ee regardless of exit reason, +distributed-process-extras provides an alternate function `linkOnFailure`, which only +dispatches the `ProcessLinkException` if the link-ed process dies abnormally (i.e., with +some `DiedReason` other than `DiedNormal`). + +Monitors on the other hand, do not cause the *listening* process to exit at all, instead +putting a `ProcessMonitorNotification` into the process' mailbox. This signal and its +constituent fields can be introspected in order to decide what action (if any) the receiver +can/should take in response to the monitored process' death. Let's take a look at how +monitors can be used to determine both when and _how_ a process has terminated. Tucked +away in distributed-process-extras, the `linkOnFailure` primitive works in exactly this +way, only terminating the caller if the subject terminates abnormally. Let's take a look... + +{% highlight haskell %} +linkOnFailure them = do + us <- getSelfPid + tid <- liftIO $ myThreadId + void $ spawnLocal $ do + callerRef <- P.monitor us + calleeRef <- P.monitor them + reason <- receiveWait [ + matchIf (\(ProcessMonitorNotification mRef _ _) -> + mRef == callerRef) -- nothing left to do + (\_ -> return DiedNormal) + , matchIf (\(ProcessMonitorNotification mRef' _ _) -> + mRef' == calleeRef) + (\(ProcessMonitorNotification _ _ r') -> return r') + ] + case reason of + DiedNormal -> return () + _ -> liftIO $ throwTo tid (ProcessLinkException us reason) +{% endhighlight %} + +As we can see, this code makes use of monitors to track both processes involved in the +link. In order to track _both_ processes and react to changes in their status, it is +necessary to spawn a third process which will do the monitoring. This doesn't happen +with the built-in link primitive, but is necessary in this case since the link handling +code resides outside the _Node Controller_. + +The two matches passed to `receiveWait` both handle a `ProcessMonitorNotification`, and +the predicate passed to `matchIf` is used to determine whether the notification we're +receiving is for the process that called us, or the _linked to_ process. If the former +dies, we've nothing more to do, since links are unidirectional. If the latter dies +however, we must examine the `DiedReason` the `ProcessMonitorNotification` provides us +with, to determine whether the subject exited normally (i.e., with `DiedNormal`). +If the exit was _abnormal_, we throw a `ProcessLinkException` to the original caller, +which is exactly how an ordinary link would behave. + +Linking and monitoring are foundational tools for *supervising* processes, where a top level +process manages a set of children, starting, stopping and restarting them as necessary. + +Exit signals in Cloud Haskell then, are unlike asynchronous exceptions in other +haskell code. Whilst a process *can* use asynchronous exceptions - there's +nothing stoping this since the `Process` monad is an instance of `MonadIO` - +as we've seen, exceptions thrown are not bound by the same ordering guarantees +as messages delivered to a process. Link failures and exit signals *might* work +via asynchronous exceptions - that is the case in the current implementation - but +these are implemented in such a fashion that if you send a message and *then* an +exit signal, the message is guaranteed to arrive first. + +You should avoid throwing your own exceptions in code where possible. Instead, +you should terminate yourself, or another process, using the built-in primitives +`exit`, `kill` and `die`. + +### Getting Process Info + +The `getProcessInfo` function provides a means for us to obtain information about a running +process. The `ProcessInfo` type it returns contains the local node id and a list of +registered names, monitors and links for the process. The call returns `Nothing` if the +process in question is not alive. + +### Monad Transformer Stacks + +It is not generally necessary, but it may be convenient in your application to use a +custom monad transformer stack with the Process monad at the bottom. For example, +you may have decided that in various places in your application you will make calls to +a network database. You may create a data access module, and it will need configuration information available to it in +order to connect to the database server. A ReaderT can be a nice way to make +configuration data available throughout an application without +schlepping it around by hand. + +This example is a bit contrived and over-simplified but +illustrates the concept. Consider the `fetchUser` function below, it runs in the `AppProcess` +monad which provides the configuration settings required to connect to the database: + +{% highlight haskell %} + +import Data.ByteString (ByteString) +import Control.Monad.Reader + +-- imagine we have some database library +import Database.Imaginary as DB + +data AppConfig = AppConfig {dbHost :: String, dbUser :: String} + +type AppProcess = ReaderT AppConfig Process + +data User = User {userEmail :: String} + +-- Perform a user lookup using our custom app context +fetchUser :: String -> AppProcess (Maybe User) +fetchUser email = do + db <- openDB + user <- liftIO $ DB.query db email + closeDB db + return user + +openDB :: AppProcess DB.Connection +openDB = do + AppConfig host user <- ask + liftIO $ DB.connect host user + +closeDB :: DB.Connection -> AppProcess () +closeDB db = liftIO (DB.close db) + +{% endhighlight %} + +So this would mostly work but it is not complete. What happens if an exception +is thrown by the `query` function? Your open database handle may not be +closed. Typically we manage this with the [bracket][brkt] function. + +In the base library, [bracket][brkt] is defined in Control.Exception with this signature: + +{% highlight haskell %} + +bracket :: IO a --^ computation to run first ("acquire resource") + -> (a -> IO b) --^ computation to run last ("release resource") + -> (a -> IO c) --^ computation to run in-between + -> IO c + +{% endhighlight %} + +Great! We pass an IO action that acquires a resource; `bracket` passes that +resource to a function which takes the resource and runs another action. +We also provide a release function which `bracket` is guaranteed to run +even if the primary action raises an exception. + + +Unfortunately, we cannot directly use `bracket` in our +`fetchUser` function: openDB (resource acquisition) runs in the `AppProcess` +monad. If our functions ran in IO, we could lift the entire bracket computation into +our monad transformer stack with liftIO; but we cannot do that for the computations +*passed* to bracket. + +It is perfectly possible to write our own bracket; `distributed-process` does this +for the `Process` monad (which is itself a newtyped ReaderT stack). Here is how that is done: + + +{% highlight haskell %} +-- | Lift 'Control.Exception.bracket' +bracket :: Process a -> (a -> Process b) -> (a -> Process c) -> Process c +bracket before after thing = + mask $ \restore -> do + a <- before + r <- restore (thing a) `onException` after a + _ <- after a + return r + +mask :: ((forall a. Process a -> Process a) -> Process b) -> Process b +mask p = do + lproc <- ask + liftIO $ Ex.mask $ \restore -> + runLocalProcess lproc (p (liftRestore restore)) + where + liftRestore :: (forall a. IO a -> IO a) + -> (forall a. Process a -> Process a) + liftRestore restoreIO = \p2 -> do + ourLocalProc <- ask + liftIO $ restoreIO $ runLocalProcess ourLocalProc p2 + +-- | Lift 'Control.Exception.onException' +onException :: Process a -> Process b -> Process a +onException p what = p `catch` \e -> do _ <- what + liftIO $ throwIO (e :: SomeException) +{% endhighlight %} + +`distributed-process` needs to do this sort of thing to keep its dependency +list small, but do we really want to write this for every transformer stack +we use in our own applications? No! And we do not have to, thanks to +the [monad-control][mctrl] and [lifted-base][lbase] libraries. + +[monad-control][mctrl] provides several typeclasses and helper functions +that make it possible to fully generalize the wrapping/unwrapping required +to keep transformer effects stashed away while actions run in the base monad. Of +most concern to end users of this library are the typeclass [MonadBase][mb] and [MonadBaseControl][mbc]. +How it works is beyond the scope of this tutorial, but there is an excellent and thorough +explanation written by Michael Snoyman which is available [here][mctrlt]. + +[lifted-base][lbase] takes advantage of these typeclasses to provide lifted versions of many functions +in the Haskell base library. For example, [Control.Exception.Lifted][lexc] has a definition of +bracket that looks like this: + +{% highlight haskell %} + +bracket :: MonadBaseControl IO m + => m a --^ computation to run first ("acquire resource") + -> (a -> m b) --^ computation to run last ("release resource") + -> (a -> m c) --^ computation to run in-between + -> m c + +{% endhighlight %} + +It is just the same as the version found in base, except it is generalized to work +with actions in any monad that implements [MonadBaseControl IO][mbc]. [monad-control][mctrl] defines +instances for the standard transformers, but that instance requires the base monad +(in this case, `Process`) to also have an instance of these classes. + +To address this the [distributed-process-monad-control][dpmc] package +provides orphan instances of the `Process` type for both [MonadBase IO][mb] and [MonadBaseControl IO][mbc]. +After importing these, we can rewrite our `fetchUser` function to use the instance of bracket +provided by [lifted-base][lbase]. + +{% highlight haskell %} + +-- ... +import Control.Distributed.Process.MonadBaseControl () +import Control.Exception.Lifted as Lifted + +-- ... + +fetchUser :: String -> AppProcess (Maybe User) +fetchUser email = + Lifted.bracket openDB + closeDB + $ \db -> liftIO $ DB.query db email + + +{% endhighlight %} + +[lifted-base][lbase] also provides conveniences like [MVar][lmvar] and other concurrency primitives that +operate in [MonadBase IO][mb]. One benefit here is that your code is not sprinkled with +liftIO; but [MonadBaseControl IO][mbc] also makes things like a lifted [withMVar][lmvar-with] possible - which is +really just a specialization of [bracket][lbrkt]. You will also find lots of other libraries on hackage which +use these instances - at present count there are more than 150 [packages using it][reverse]. + +One note of caution: This instance can enable use of functions such as `forkIO` (or, `fork` from [lifted-base][lbase]) which compromise invariants in the `Process` monad and can lead to confusing and subtle issues. Always use the Cloud Haskell functions such as spawnLocal instead. + + +[1]: hackage.haskell.org/package/distributed-process/docs/Control-Distributed-Process.html#v:receiveWait +[2]: hackage.haskell.org/package/distributed-process/docs/Control-Distributed-Process.html#v:expect +[3]: http://hackage.haskell.org/package/distributed-process-0.4.2/docs/Control-Distributed-Process.html#v:match +[4]: /static/semantics.pdf +[5]: http://hackage.haskell.org/package/distributed-process-0.4.2/docs/Control-Distributed-Process.html#v:exit +[6]: http://hackage.haskell.org/package/distributed-process-0.4.2/docs/Control-Distributed-Process.html#v:kill +[7]: http://hackage.haskell.org/package/distributed-process-0.4.2/docs/Control-Distributed-Process.html#v:die +[brkt]: http://hackage.haskell.org/package/base-4.6.0.1/docs/Control-Exception.html#v:bracket +[mctrl]: http://hackage.haskell.org/package/monad-control +[mb]: http://hackage.haskell.org/package/transformers-base-0.4.2/docs/Control-Monad-Base.html#t:MonadBase +[mbc]: http://hackage.haskell.org/package/monad-control-0.3.3.0/docs/Control-Monad-Trans-Control.html#t:MonadBaseControl +[lmvar]: http://hackage.haskell.org/package/lifted-base-0.2.2.2/docs/Control-Concurrent-MVar-Lifted.html#t:MVar +[lmvar-with]: http://hackage.haskell.org/package/lifted-base-0.2.2.2/docs/Control-Concurrent-MVar-Lifted.html#v:withMVar +[lbrkt]: http://hackage.haskell.org/package/lifted-base-0.2.2.2/docs/Control-Exception-Lifted.html#v:bracket +[lbase]: http://hackage.haskell.org/package/lifted-base +[dpmc]: http://hackage.haskell.org/package/distributed-process-monad-control +[mctrlt]: http://www.yesodweb.com/book/monad-control +[reverse]: http://packdeps.haskellers.com/reverse/monad-control +[lexc]: http://hackage.haskell.org/package/lifted-base-0.2.2.2/docs/Control-Exception-Lifted.html diff --git a/website/tutorials/4ch.md b/website/tutorials/4ch.md new file mode 100644 index 00000000..fddc1d44 --- /dev/null +++ b/website/tutorials/4ch.md @@ -0,0 +1,673 @@ +--- +layout: tutorial +sections: ['Introduction', 'Managed Processes', 'A Basic Example', 'Building a Task Queue', 'Implementing the Client', 'Implementing the Server', 'Making use of Async', 'Wiring up Handlers', 'Putting it all together', 'Performance Considerations'] +categories: tutorial +title: 4. Managed Process Tutorial +--- + +### Introduction + +The source code for this tutorial is based on the `BlockingQueue` API +from distributed-process-task and can be accessed [here][1]. +Please note that this tutorial is based on the stable (master) branch +of [distributed-process-task][3]. + +### Managed Processes + +There may be subtle bugs hiding in code that evaluates `send` and `receive` +directly. Forgetting to monitor the destination whilst waiting for a reply +or failing to match on the correct message types are the most common and +other, more esoteric problems exist, such as badly formed `Binary` instances +for user defined data types which can crash the sender or worse, in the +presence of [_unsafe operations_][4] and unevaluated thunks, unexpectedly +crash the receiver. + +The /Managed Process/ API handles sending to and receiving from the server +process, in-process error handling and message decoding, leaving you to focus +on writing code that describes _what the server process does_ when it receives +messages, rather than how it receives them. The API also provides a set of +pre-defined client interactions, all of which have well defined semantics +and failure modes. There is support for sending messages to/from a process' +mailbox, using typed channels for inputs and outputs, RPC calls (i.e., waiting +for a reply from the server) and fire-and-forget client-server messages. + +Managed processess are defined using record syntax, providing lists of +`Dispatcher` objects describing how the server handles particular kinds of +client interaction for specific input types. The `ProcessDefinition` record +also provides hooks for error handling (in case of either server code crashing +_or_ exit signals dispatched to the server process from elsewhere) and _cleanup_ +code to be run on termination/shutdown. + +{% highlight haskell %} +myServer :: ProcessDefinition MyStateType +myServer = + ProcessDefinition { + -- handle messages sent to us via the call/cast API functions + apiHandlers = [ + -- a list of Dispatchers, derived by calling on of the various + -- handle functions with a suitable thunk, e.g., + handleCast myFunctionThatDoesNotReply + , handleCall myFunctionThatDoesReply + , handleRpcChan myFunctionThatRepliesViaTypedChannels + ] + + -- handle messages that can only be sent directly to our mailbox + -- (i.e., without going through the call/casts APIs), such as + -- `ProcessMonitorNotification` + , infoHandlers = [ + -- a list of DeferredDispatcher, derived from calling + -- handleInfo or handleRaw with a suitable function, e.g., + handleInfo myFunctionThatHandlesOneSpecificNonCastNonCallMessageType + , handleRaw myFunctionThatHandlesRawMessages + ] + + -- what should we do about exit signals? + , exitHandlers = [ + -- a list of ExitSignalDispatcher, derived from calling + -- handleExit with a suitable function, e.g., + handleExit myExitHandlingFunction + ] + + -- what should I do just before stopping? + , shutdownHandler = myShutdownFunction + + -- what should I do about messages that cannot be handled? + , unhandledMessagePolicy = Drop -- Terminate | (DeadLetter ProcessId) + } + +{% endhighlight %} + +When defining a protocol between client and server, we typically decide on +a set of types the server will handle and possibly maps these to replies we +may wish to send back. The `cast` and `call` mechanisms cater for this +specifically, providing tight control over the domain of input messages from +clients, whilst ensuring that client code handles errors consistently and +input messages are routed to a suitable message handling function in the +server process. + +In the following example, we'll take a look at this API in action. + +--------- + +### A Basic Example + +Let's consider the simple _math server_ we encountered in the high level +[documentation][5]. We could allow clients to send us a tuple of +`(ProcessId, Double, Double)`, replying to the first tuple element with the +sum of the second and third. What happens if our server process is killed +while the client is waiting for the reply though? The client would deadlock. +Clients could always set up a monitor and wait for the reply _or_ a monitor +signal, and could even write such code generically, but what if the code +evaluating some such utility function then `expect`s the wrong type? We could +use a typed channel to alleviate that ill, but that only helps with the client +receiving messages, not the server. How can we ensure that the server receives +the correct type(s) as well? Creating multiple typed channels (one for each +kind of message we're expecting) and then distributing those to all our clients +is awkward at best (though we will see how to do something like this using the +API in a later tutorial). + +The `call` and `cast` APIs help us to avoid this conundrum, providing a uniform +API for both the client _and_ the server to observe. Here's a better example of +that math server that does just that: + +---- + +{% highlight haskell %} +module MathServer + ( -- client facing API + add + -- starting/spawning the server process + , launchMathServer + ) where + +import Control.Distributed.Process.ManagedProcess -- from the package `distributed-process-client-server` +import Control.Distributed.Process.Extras.Time -- from the package `distributed-process-extras` +import .... -- elided + +-- We keep this data-type hidden from the outside world, and we ignore +-- messages sent to us that we do not recognise, so misbehaving clients +-- (who do not use our API) are basically ignored. +data Add = Add Double Double + deriving (Typeable, Generic) +instance Binary Add where + +-- client facing API + +-- This is the only way clients can get a message through to us that +-- we will respond to, and since we control the type(s), there is no +-- risk of decoding errors on the server. The /call/ API ensures that +-- if the server does fail for some other reason however (such as being +-- killed by another process), the client will get an exit signal also. +-- +add :: ProcessId -> Double -> Double -> Process Double +add sid = call sid . Add + +-- server side code + +launchMathServer :: Process ProcessId +launchMathServer = + let server = statelessProcess { + apiHandlers = [ handleCall_ (\(Add x y) -> return (x + y)) ] + , unhandledMessagePolicy = Drop + } + in spawnLocal $ serve () (statelessInit Infinity) server >> return () +{% endhighlight %} + + +This style of programming will already be familiar if you've used some +combination of `send` in your clients and the `receive [ match ... ]` +family of functions to write your servers. The primary difference here, +is that the choice of when to return to (potentially blocking on) the +server's mailbox is taken out of the programmer's hands, leaving the +implementor to worry only about the logic to be applied once a message +of one type or another is received. + +We could even hide the math server behind a newtype and prevent messages +being sent to its `ProcessId` altogether, but we will leave that as an +exercise for the reader. + +---- + +Of course, it would still be possible to write the server and client code +and encounter data type decoding failures, since the `call` function takes +an arbitrary `Serializable` datum just like `send`. We can solve that for +the return type of the _remote_ call by sending a typed channel and +replying explicitly to it in our server side code. Whilst this doesn't +make the server code any prettier (since it has to reply to the channel +explicitly, rather than just evaluating to a result), it does reduce the +likelihood of runtime errors somewhat. + +{% highlight haskell %} +-- This is the only way clients can get a message through to us that +-- we will respond to, and since we control the type(s), there is no +-- risk of decoding errors on the server. The /call/ API ensures that +-- if the server does fail for some other reason however (such as being +-- killed by another process), the client will get an exit signal also. +-- +add :: ProcessId -> Double -> Double -> Process Double +add sid = syncCallChan sid . Add + +launchMathServer :: Process ProcessId +launchMathServer = + let server = statelessProcess { + apiHandlers = [ handleRpcChan_ (\chan (Add x y) -> sendChan chan (x + y)) ] + , unhandledMessagePolicy = Drop + } + in spawnLocal $ serve () (statelessInit Infinity) server >> return () +{% endhighlight %} + +Ensuring that only valid types are sent to the server is relatively simple, +given that we do not expose the client directly to `call` and write our own +wrapper functions. An additional level of isolation and safety is available +when using /control channels/, which will be covered in a subsequent tutorial. + +Before we leave the math server behind, let's take a brief look at the `cast` +part of the client-server protocol. Unlike its synchronous cousin, `cast` does +not expect a reply at all - it is a fire and forget call, much like `send`, +but carries the same additional type information that a `call` does (about its +inputs) and is also routed to a `Dispatcher` in the `apiHandlers`[2] field of +the process definition. + +We will use cast with the existing `Add` type, to implement a function that +takes an /add request/ and prints the result instead of returning it. If we +were implementing this with `call` we would be a bit stuck, because there is +nothing to differentiate between two `Add` instances and the server would +choose the first valid (i.e., type safe) handler and ignore the others we'd +declared. + +Also note that because the client doesn't wait for a reply, if you execute +this function in a test/demo application, you'll need to block the main +thread for a while to wait for the server to receive the message and print +out the result. + +{% highlight haskell %} + +printSum :: ProcessId -> Double -> Double -> Process () +printSum sid = cast sid . Add + +launchMathServer :: Process ProcessId +launchMathServer = + let server = statelessProcess { + apiHandlers = [ handleRpcChan_ (\chan (Add x y) -> sendChan chan (x + y) >> continue_) + , handleCast_ (\(Add x y) -> liftIO $ putStrLn $ show (x + y) >> continue_) ] + , unhandledMessagePolicy = Drop + } + in spawnLocal $ serve () (statelessInit Infinity) server >> return () +{% endhighlight %} + + +Of course this is a toy example - why defer simple computations like addition +and/or printing results to a separate process? Next, we'll build something a bit +more interesting and useful. + +### Building a Task Queue + +This section of the tutorial is based on a real module from the +distributed-process-task library, called `BlockingQueue`. + +Let's imagine we want to execute tasks on an arbitrary node, but want +the caller to block whilst the remote task is executing. We also want +to put an upper bound on the number of concurrent tasks/callers that +the server will accept. Let's use `ManagedProcess` to implement a generic +task server like this, with the following characteristics + +* requests to enqueue a task are handled immediately +* callers however, are blocked until the task completes (or fails) +* an upper bound is placed on the number of concurrent running tasks + +Once the upper bound is reached, tasks will be queued up for execution. +Only when we drop below this limit will tasks be taken from the backlog +and executed. + +Since we want the server to proceed with its work whilst the client is +blocked, the asynchronous `cast` API may sound like the ideal approach, +or we might use the asynchronous cousin of our typed-channel +handling API `callChan`. The `call` API however, offers exactly the +tools we need to keep the client blocked (waiting for a reply) whilst +the server is allowed to proceed with its work. + +### Implementing the client + +We'll start by thinking about the types we need to consume in the server +and client processes: the tasks we're being asked to perform. + +To submit a task, our clients will submit an action in the process +monad, wrapped in a `Closure` environment. We will use the `Addressable` +typeclass to allow clients to specify the server's location in whatever +manner suits them: The type of a task will be `Closure (Process a)` and +the server will explicitly return an /either/ value with `Left String` +for errors and `Right a` for successful results. + +{% highlight haskell %} +-- enqueues the task in the pool and blocks +-- the caller until the task is complete +executeTask :: forall s a . (Addressable s, Serializable a) + => s + -> Closure (Process a) + -> Process (Either String a) +executeTask sid t = call sid t +{% endhighlight %} + +Remember that in Cloud Haskell, the only way to communicate with a process +(apart from introducing scoped concurrency primitives like `MVar` or using +stm) is via its mailbox and typed channels. Also, all communication with +the process is asynchronous from the sender's perspective and synchronous +from the receiver's. Although `call` is a synchronous (RPC-like) protocol, +communication with the *server process* has to take place out of band. + +The server implementation chooses to reply to each request and when handling +a `call`, can defer its reply until a later stage, thus going back to +receiving and processing other messages in the meantime. As far as the client +is concerned, it is simply waiting for a reply. Note that the `call` primitive +is implemented so that messages from other processes cannot interleave with +the server's response. This is very important, since another message of type +`Either String a` could theoretically arrive in our mailbox from somewhere +else whilst we're receiving, therefore `call` transparently tags the call +message and awaits a specific reply from the server (containing the same +tag). These tags are guaranteed to be unique across multiple nodes, since +they're based on a `MonitorRef`, which holds a `Identifier ProcessId` and +a node local monitor ref counter. All monitor creation is coordinated by +the caller's node controller (guaranteeing the uniqueness of the ref +counter for the lifetime of the node) and the references are not easily +forged (i.e., sent by mistake - this is not a security feature of any sort) +since the type is opaque. + +In terms of code for the client then, that's all there is to it! +Note that the type signature we expose to our consumers is specific, and that +we do not expose them to arbitrary messages arriving in their mailbox. Note +that if a `call` fails, a `ProcessExitException` will be thrown in the caller's +thread (since the implementation calls `die` if it detects that the server has +died before replying). Other variations of `call` exist that return a `Maybe` or +an `Either ExitReason a` instead of making the caller's process exit. + +Note that if the server replies to this call with some other type (i.e., a type +other than `Either String a`) then our client will be blocked indefinitely! +We could alleviate this by using a typed channel as we saw previously with our +math server, but there's little point since we're in total charge of both the +client and the server's code. + +### Implementing the server + +To implement the server, we'll need to hang on to some internal state. As well as +knowing our queue's size limit, we will need to track the _active_ tasks we're +currently running. Each task will be submitted as a `Closure (Process a)` and we'll +need to spawn the task (asynchronously), handle the result (once the closure has +run to completion) and communicate the result (or failure) to the original caller. + +This means our pool state will need to be parameterised by the result type it will +accept in its closures. So now we have the beginnings of our state type: + +{% highlight haskell %} +data BlockingQueue a = BlockingQueue +{% endhighlight %} + +### Making use of Async + +So **how** can we execute this `Closure (Process a)` without blocking the server +process itself? We can use the `Control.Distributed.Process.Async` API +to execute each task asynchronously and provide a means for waiting on the result. + +In order to use an `Async` handle to get the result of the computation once it's +complete, we'll have to hang on to a reference. We also need a way to associate the +submitter with the handle, so we end up with one field for the active (running) +tasks and another for the queue of accepted (but inactive) ones, as expected. + +Since we cannot wait on all these `Async` handles at once whilst we're supposed to +be accepting new messages from clients - actually, [distributed-process-async][6] does provide an API for +multiplexing on async results, but that's no use here - instead we will monitor the +async tasks and pull the results when we receive their monitor signals. So for the +active tasks, we'll need to store a `MonitorRef` and a reference to the original +caller, plus the async handle itself. We'll use a simple association list for this +state, though we should probably use a more optimal data structure eventually. + +For the tasks that we cannot execute immediately (i.e., when we reach the queue's +size limit), we hold the client ref and the closure, but no monitor ref. We'll +use a data structure that support FIFO ordering semantics for this, since that's +probably what clients will expect of something calling itself a "queue". + +{% highlight haskell %} +data BlockingQueue a = BlockingQueue { + poolSize :: SizeLimit + , active :: [(MonitorRef, CallRef (Either ExitReason a), Async a)] + , accepted :: Seq (CallRef (Either ExitReason a), Closure (Process a)) + } +{% endhighlight %} + +Our queue-like behaviour is fairly simple to define using `Data.Sequence`: + +{% highlight haskell %} +enqueue :: Seq a -> a -> Seq a +enqueue s a = a <| s + +dequeue :: Seq a -> Maybe (a, Seq a) +dequeue s = maybe Nothing (\(s' :> a) -> Just (a, s')) $ getR s + +getR :: Seq a -> Maybe (ViewR a) +getR s = + case (viewr s) of + EmptyR -> Nothing + a -> Just a +{% endhighlight %} + + +Now, to turn that `Closure` environment into a thunk we can evaluate, we'll use the +built in `unClosure` function, and we'll pass the thunk to `async` and get back +a handle to the running async task, which we'll then need to monitor. We won't cover +the async API in detail here, except to point out that the call to `async` spawns a +new process to do the actual work and returns a handle that we can use to query for +the result. + +{% highlight haskell %} +proc <- unClosure task' +asyncHandle <- async proc +ref <- monitorAsync asyncHandle +{% endhighlight %} + +We can now implement the `acceptTask` function, which the server will use to handle +submitted tasks. The signature of our function must be compatible with the message +handling API from `ManagedProcess` that we're going to use it with - in this case +`handleCallFrom`. This variant of the `handleCall` family of functions is specifically +intended for use when the server is going to potentially delay its reply, rather than +replying immediately. It takes an expression that operates over our server's state, a +`CallRef` that uniquely identifies the caller and can be used to reply to them later +on and the message that was sent to the server - in this case, a `Closure (Process a)`. + +All managed process handler functions must return either a `ProcessAction`, indicating +how the server should proceed, or a `ProcessReply`, which combines a `ProcessAction` +with a possible reply to one of the `call` derivatives. Since we're deferring our reply +until later, we will use `noReply_`, which creates a `ProcessAction` for us, telling +the server to continue receiving messages. + +{% highlight haskell %} +storeTask :: Serializable a + => BlockingQueue a + -> CallRef (Either ExitReason a) + -> Closure (Process a) + -> Process (ProcessReply (Either ExitReason a) (BlockingQueue a)) +storeTask s r c = acceptTask s r c >>= noReply_ + +acceptTask :: Serializable a + => BlockingQueue a + -> CallRef (Either ExitReason a) + -> Closure (Process a) + -> Process (BlockingQueue a) +acceptTask s@(BlockingQueue sz' runQueue taskQueue) from task' = + let currentSz = length runQueue + in case currentSz >= sz' of + True -> do + return $ s { accepted = enqueue taskQueue (from, task') } + False -> do + proc <- unClosure task' + asyncHandle <- async proc + ref <- monitorAsync asyncHandle + let taskEntry = (ref, from, asyncHandle) + return s { active = (taskEntry:runQueue) } +{% endhighlight %} + +If we're at capacity, we add the task (and caller) to the `accepted` queue, +otherwise we launch and monitor the task using `async` and stash the monitor +ref, caller ref and the async handle together in the `active` field. + +Now we must write a function that handles the results of these closures. When +a monitor signal arrives in our mailbox, we need to lookup the async handle +associated with it so as to obtain the result and send it back to the caller. +Because, even if we were running at capacity, we've now seen a task complete +(and therefore reduced the number of active tasks by one), we will also pull +off a pending task from the backlog (i.e., accepted), if any exists, and execute +it. + +The steps then, are + +1. find the async handle for our monitor ref +2. obtain the result using the handle +3. send the result to the client +4. bump another task from the backlog (if there is one) +5. carry on + +This chain then, looks like `wait >>= respond >> bump-next-task >>= continue`. + +Item (3) requires special API support from `ManagedProcess`, because we're not +just sending *any* message back to the caller. We're replying to a specific `call` +that has taken place and is, from the client's perspective, still running. +The `ManagedProcess` API call for this is `replyTo`. + +There is quite a bit of code in this next function, which we'll look at in detail. +Firstly, note that the signature is similar to the one we used for `storeTask`, but +returns just a `ProcessAction` instead of `ProcessReply`. This function will not be +wired up to a `call` (or even a `cast`), because the node controller will send the +monitor signal directly to our mailbox, not using the managed process APIs at all. +This kind of client interaction is called an _info call_ in the managed process API, +and since there's no expected reply, as with `cast`, we simply return a `ProcessAction` +telling the server what to do next - in this case, to `continue` reading from the +mailbox. + +{% highlight haskell %} +taskComplete :: forall a . Serializable a + => BlockingQueue a + -> ProcessMonitorNotification + -> Process (ProcessAction (BlockingQueue a)) +taskComplete s@(BlockingQueue _ runQ _) + (ProcessMonitorNotification ref _ _) = + let worker = findWorker ref runQ in + case worker of + Just t@(_, c, h) -> wait h >>= respond c >> bump s t >>= continue + Nothing -> continue s + + where + respond :: CallRef (Either ExitReason a) + -> AsyncResult a + -> Process () + respond c (AsyncDone r) = replyTo c ((Right r) :: (Either ExitReason a)) + respond c (AsyncFailed d) = replyTo c ((Left (ExitOther $ show d)) :: (Either ExitReason a)) + respond c (AsyncLinkFailed d) = replyTo c ((Left (ExitOther $ show d)) :: (Either ExitReason a)) + respond _ _ = die $ ExitOther "IllegalState" + + bump :: BlockingQueue a + -> (MonitorRef, CallRef (Either ExitReason a), Async a) + -> Process (BlockingQueue a) + bump st@(BlockingQueue _ runQueue acc) worker = + let runQ2 = deleteFromRunQueue worker runQueue + accQ = dequeue acc in + case accQ of + Nothing -> return st { active = runQ2 } + Just ((tr,tc), ts) -> acceptTask (st { accepted = ts, active = runQ2 }) tr tc + +findWorker :: MonitorRef + -> [(MonitorRef, CallRef (Either ExitReason a), Async a)] + -> Maybe (MonitorRef, CallRef (Either ExitReason a), Async a) +findWorker key = find (\(ref,_,_) -> ref == key) + +deleteFromRunQueue :: (MonitorRef, CallRef (Either ExitReason a), Async a) + -> [(MonitorRef, CallRef (Either ExitReason a), Async a)] + -> [(MonitorRef, CallRef (Either ExitReason a), Async a)] +deleteFromRunQueue c@(p, _, _) runQ = deleteBy (\_ (b, _, _) -> b == p) c runQ +{% endhighlight %} + +We've dealt with mapping the `AsyncResult` to `Either` values, which we *could* have +left to the caller, but this makes the client facing API much simpler to work with. +Note that our use of an association list for the active _run queue_ makes for an +O(n) search for our worker, but that can be optimised with a map or dictionary later. +Worse, we have to scan the list again when deleting the worker from the _run queue_, +but the same fix (using a Map) should alleviate that problem too. We leave that as +an exercise for the reader. + +### Wiring up handlers + +Call and cast handlers live in the `apiHandlers` list of our `ProcessDefinition` +and have the type `Dispatcher s` where `s` is the state type for the process. We +cannot construct a `Dispatcher` ourselves, but a range of functions in the +`ManagedProcess.Server` module exist to convert functions like the ones we've just +defined, to the correct type. + +In order to spell things out for the compiler, we need to put a type signature +in place at the call site for `storeTask`, so our final construct for that +handler is thus: + +{% highlight haskell %} +handleCallFrom (\s f (p :: Closure (Process a)) -> storeTask s f p) +{% endhighlight %} + +No such thing is required for `taskComplete`, as there's no ambiguity about its +type. Our process definition is now finished, and here it is: + +{% highlight haskell %} +defaultProcess { + apiHandlers = [ + handleCallFrom (\s f (p :: Closure (Process a)) -> storeTask s f p) + , handleCall poolStatsRequest + ] + , infoHandlers = [ handleInfo taskComplete ] + } +{% endhighlight %} + +Starting the server takes a bit of work: `ManagedProcess` provides several +utility functions to help with spawning and running processes. The `serve` +function takes an _initialising_ thunk (which has the type `InitHandler`) +that must generate the initial state and set up the server's receive timeout, +then the process definition which we've already encountered. For more details +about starting managed processes, see the haddocks. + +{% highlight haskell %} +run :: forall a . (Serializable a) + => Process (InitResult (BlockingQueue a)) + -> Process () +run init' = ManagedProcess.serve () (\() -> init') poolServer + where poolServer = + defaultProcess { + apiHandlers = [ + handleCallFrom (\s f (p :: Closure (Process a)) -> storeTask s f p) + , handleCall poolStatsRequest + ] + , infoHandlers = [ handleInfo taskComplete ] + } :: ProcessDefinition (BlockingQueue a) + +pool :: forall a . Serializable a + => SizeLimit + -> Process (InitResult (BlockingQueue a)) +pool sz' = return $ InitOk (BlockingQueue sz' [] Seq.empty) Infinity +{% endhighlight %} + +### Putting it all together + +Defining tasks is as simple as making them remote-worthy: + +{% highlight haskell %} +sampleTask :: (TimeInterval, String) -> Process String +sampleTask (t, s) = sleep t >> return s + +$(remotable ['sampleTask]) +{% endhighlight %} + +And executing them is just as simple too. + +{% highlight haskell %} +tsk <- return $ ($(mkClosure 'sampleTask) (seconds 2, "foobar")) +executeTask taskQueuePid tsk +{% endhighlight %} + +Starting up the server itself locally or on a remote node, is just a matter of +combining `spawn` or `spawnLocal` with `start`. We can go a step further though, +and add a bit more type safety to our API by using an opaque handle to communicate +with the server. The advantage of this is that it right now it is possible for +a client to send a `Closure` to the server with a return type different from the +one the server is expecting! Since the server won't recognise that message, the +`unhandledMessagePolicy` will be applied, which by default crashes the server with +an exit reason referring to "unhandled inputs"! + +By returning a handle to the server using a parameterised type, we can ensure that +only closures returning a matching type are sent. To do so, we use a phantom type +parameter and simply stash the real `ProcessId` in a newtype. We also need to be +able to pass this handle to the managed process `call` API, so we define an +instance of the `Resolvable` typeclass for it, which makes a (default) instance of +`Routable` available, which is exactly what `call` is expecting: + +{% highlight haskell %} +newtype TaskQueue a = TaskQueue { unQueue :: ProcessId } + +instance Resolvable (TaskQueue a) where + resolve = return . unQueue +{% endhighlight %} + +Finally, we write a `start` function that returns this handle and change the +signature of `executeTask` to match it: + +{% highlight haskell %} +start :: forall a . (Serializable a) + => SizeLimit + -> Process (TaskQueue a) +start lim = spawnLocal (start $ pool lim) >>= return . TaskQueue + +-- ....... + +executeTask :: (Serializable a) + => TaskQueue a + -> Closure (Process a) + -> Process (Either ExitReason a) +executeTask sid t = call sid t +{% endhighlight %} + +---------- + +In this tutorial, we've really just scratched the surface of the `ManagedProcess` +API. By handing over control of the client/server protocol to the framework, we +are able to focus on the code that matters, such as state transitions and decision +making, without getting bogged down (much) with the business of sending and +receiving messages, handling client/server failures and such like. + +### Performance Considerations + +We did not take much care over our choice of data structures. Might this have +profound consequences for clients? Perhaps more of a concern is the cost of +using `Async` everywhere - remember we used this in the *server* to handle +concurrently executing tasks and obtaining their results. An invocation of +`async` will create two new processes: one to perform the calculation and +another to monitor the first and handle failures and/or cancellation. Spawning +processes is cheap, but not free as each process is a haskell thread, plus some +additional book keeping data. + +[1]: https://github.com/haskell-distributed/distributed-process-task/blob/master/src/Control/Distributed/Process/Task/Queue/BlockingQueue.hs +[2]: https://hackage.haskell.org/package/distributed-process-client-server-0.1.3.2/docs/Control-Distributed-Process-ManagedProcess.html#t:ProcessDefinition +[3]: https://github.com/haskell-distributed/distributed-process-task +[4]: https://github.com/haskell-distributed/distributed-process-extras/blob/master/src/Control/Distributed/Process/Extras/UnsafePrimitives.hs +[5]: /documentation.html +[6]: https://hackage.haskell.org/package/distributed-process-async diff --git a/website/tutorials/5ch.md b/website/tutorials/5ch.md new file mode 100644 index 00000000..1811c8f2 --- /dev/null +++ b/website/tutorials/5ch.md @@ -0,0 +1,151 @@ +--- +layout: tutorial +categories: tutorial +sections: ['Introduction', 'Quis custodiet ipsos custodes', 'Isolated Restarts', 'All or nothing restarts'] +title: 5. Supervision Principles +--- + +### Introduction + +In previous tutorial, we've looked at utilities for linking processes together +and monitoring their lifecycle as it changes. The ability to link and monitor are +foundational tools for building _reliable_ systems and are the bedrock principles +on which Cloud Haskell's supervision capabilities are built. + +A `Supervisor` manages a set of _child processes_ throughout their entire lifecycle, +from birth (spawning) till death (exiting). Supervision is a key component in building +fault tolerant systems, providing applications with a structured way to recover from +isolated failures without the whole system crashing. Supervisors allow us to structure +our applications as independently managed subsystems, each with its own dependencies +(and inter-dependencies with other subsystems) and specify various policies determining +the fashion in which these subsystems are to be started, stopped (i.e., terminated) +and how they should behave at each level in case of failures. + +Supervisors also provide a convenient means to shut down a system (or subsystem) in a +controlled fashion, since supervisors will always terminate their children before +exiting themselves and do so based on the policies supplied when they were initially +created. + +### Quis custodiet ipsos custodes + +Supervisors can be used to construct a tree of processes, where some children are +workers (e.g., regular processes) and others are themselves supervisors. Each supervisor +is responsible for monitoring its children and handling child failures by policy, as +well as deliberately terminating children when instructed to do so (either explicitly +per child, or when the supervisor is itself told to terminate). + +Each supervisor takes with a list of _child specifications_, which tell the supervisor +how to interact with its children. Each specification provides the supervisor with the +following information about the corresponding child process: + +1. `ChildKey`: used to identify the child specification and process (once it has started) +2. `ChildType`: indicates whether the child is a worker or another (nested) supervisor +3. `RestartPolicy`: tells the supervisor under what circumstances the child should be restarted +4. `ChildTerminationPolicy`: tells the supervisor how to terminate the child, should it need to +5. `ChildStart`: provides a means for the supervisor to start/spawn the child process + +The `RestartPolicy` determines the circumstances under which a child should be +restarted when the supervisor detects that it has exited. A `Permanent` child will +always be restarted, whilst a `Temporary` child is never restarted. `Transient` children +are only restarted if the exit normally (i.e., the `DiedReason` the supervisor sees for +the child is `DiedNormal` rather than `DiedException`). `Intrinsic` children behave +exactly like `Transient` ones, except that if they terminate normally, the whole +supervisor (i.e., all the other children) exits normally as well, as if someone had +triggered the shutdown/terminate sequence for the supervisor's process explicitly. + +When a supervisor is told directly to terminate a child process, it uses the +`ChildTerminationPolicy` to determine whether the child should be terminated +_gracefully_ or _brutally killed_. This _shutdown protocol_ is used throughout +[distributed-process-supervisor][dpp] and in order for a child process to be managed +effectively by its supervisor, it is imperative that it understands the protocol. +When a _graceful_ shutdown is required, the supervisor will send an exit signal to the +child process, with the `ExitReason` set to `ExitShutdown`, whence the child process is +expected to perform any required cleanup and then exit with the same `ExitReason`, +indicating that the shutdown happened cleanly/gracefully. On the other hand, when +the `RestartPolicy` is set to `TerminateImmediately`, the supervisor will not send +an exit signal at all, calling the `kill` primitive instead of the `exit` primitive. +This immediately kills the child process without giving it the opportunity to clean +up its internal state at all. The gracefull shutdown mode, `TerminateTimeout`, must +provide a timeout value. The supervisor attempts a _gracefull_ shutdown initially, +however if the child does not exit within the given time window, the supervisor will +automatically revert to a _brutal kill_ using `TerminateImmediately`. If the +timeout value is set to `Infinity`, the supervisor will wait indefintiely for the +child to exit cleanly. + +When a supervisor detects a child exit, it will attempt a restart. Whilst explicitly +terminating a child will **only** terminate the specified child process, unexpected +child exits can trigger a _branch restart_, where other (sibling) child processes are +restarted along with the child that failed. How the supervisor goes about this +_branch restart_ is governed by the `RestartStrategy` given when the supervisor is +first started. + +------ +> ![Info: ][info] Whenever a `RestartStrategy` causes multiple children to be restarted +> in response to a single child failure, a _branch restart_ incorporating some (possibly +> a subset) of the supervisor's remaining children will be triggered. The exceptions +> to this rule are `Temporary` children and `Transient` children that exit normally, +> therefore **not** triggering a restart. The basic rule of thumb is that, if a child +> should be restarted and the `RestartStrategy` is not `RestartOne`, then a _branch_ +> containing some other children will be restarted as well. +------ + +### Isolated Restarts + +The `RestartOne` strategy is very simple. When one child fails, only that individual +child is restarted and its siblings are left running. Use `RestartOne` whenever the +processes being supervised are completely independent of one another, or a child can +be restarted and lose it's state without adversely affecting its siblings. + +------- +![Sup1: ][sup1] +------- + +### All or nothing restarts + +The `RestartAll` strategy is used when our children are all inter-dependent and it's +necessary to restart them all whenever one child crashes. This strategy triggers one of +those _branch restarts_ we mentioned earlier, which in this case means that **all** the +supervisor's children are restarted if any child fails. + +The order and manner in which the surviving children are restarted depends on the chosen +`RestartMode` which parameterises the `RestartStrategy`. This comes in three flavours: + +1. `RestartEach`: stops then starts each child sequentially +2. `RestartInOrder`: stops all children first (in order), then restarts them sequentially +3. `RestartRevOrder`: stops all children in one order, then restarts them sequentially in the opposite + +Each `RestartMode` is further parameterised by its `RestartOrder`, which is either left +to righ, or right to left. To illustrate, we will consider three alternative configurations +here, starting with `RestartEach` and `LeftToRight`. + +------- +![Sup2: ][sup2] +------- + +There are times when we need to shut down all the children first, before restarting them. +The `RestartInOrder` mode will do this, shutting the children down according to our chosen +`RestartOrder` and then starting them up in the same way. Here's an example demonstrating +`RestartInOrder` using `LeftToRight`. + +------- +![Sup3: ][sup3] +------- + +If we'd chosen `RightToLeft`, the children would have been stopped from right to left (i.e., +starting with child-3, then child-2, etc) and then restarted in the same order. + +The astute reader might've noticed that so far, we've yet to demonstrate the behaviour that's +default in [Erlang/OTP's Supervisor][erlsup], and it's a default for good reason. It is not +uncommon for children to depend on one another and therefore need to be started in the correct +order. Since these children rely on their siblings to function, we must stop them in the opposite +order, otherwise the dependent children might crash whilst we're restarting other processes they +rely on. It follows that, in this setup, we cannot subsequently (re)start the children in the +same order we stopped them either. + +[dpp]: https://github.com/haskell-distributed/distributed-process-supervisor +[sup1]: /img/one-for-one.png +[sup2]: /img/one-for-all.png +[sup3]: /img/one-for-all-left-to-right.png +[alert]: /img/alert.png +[info]: /img/info.png +[erlsup]: http://www.erlang.org/doc/man/supervisor.html diff --git a/website/tutorials/6ch.md b/website/tutorials/6ch.md new file mode 100644 index 00000000..29a32c60 --- /dev/null +++ b/website/tutorials/6ch.md @@ -0,0 +1,579 @@ +--- +layout: tutorial +sections: ['Introduction', 'Unexpected Messages', 'Hiding Implementation Details', 'Using Typed Channels'] +categories: tutorial +title: 6. Advanced Managed Processes +--- + +### Introduction + +In this tutorial, we will look at some advanced ways of programming Cloud Haskell +using the managed process API. + +### Unexpected Messages + +The process definition's [`UnhandledMessagePolicy`][policy] provides a way for +processes to respond to unexpected inputs. This proves surprisingly important, +since it is always possible for messages to unexpectedly arrive in a process' +mailbox, either those which do not match the server's expected types or which +fail one or more match conditions against the message body. + +As we will see shortly, there are various ways to ensure that only certain +messages (i.e., types) are sent to a process, but in the presense of monitoring +and other system management facilities and since the node controller is +responsible - both conceptually and by implementation - for dispatching messages +to each process' mailbox, it is impractical to make real guarantees about a +process' total input domain. Such policies are best enforced with session types, +which is part of the Cloud Haskell roadmap, but unconnected to managed processes. + +During development, the handy `Log` option will write an info message to the +[_SystemLog_][3] with information about unexpected inputs (including type info), +whilst in production, the obvious choice is between the silent `Drop` and its +explosive sibling, `Terminate`. Since in Cloud Haskell's open messaging architecture, +it is impossible to guarantee against unexpected messages (even in the presence + of advanced protocol enforcement tools such as session types), whichever option +is chosen, the server must have some policy for dealing with unexpected messages. + +------ +> ![Warning: ][alert] Watch out for unhandled deliveries, especially when using +> the `Drop` policy. In particular, unhandled message _types_ are a common cause +> of application failure and when servers discard messages without notifying their +> clients, deadlocks will quickly ensue! +------ + +### Hiding Implementation Details + +Whilst there is nothing to stop clients from sending messages directly to a +managed process, there are ways to avoid this (in most cases) by hiding our +`ProcessId`, either behind a _newtype_ or some other opaque data structure). +The author of the server is then able to force clients through API calls that +can enforce the required types _and_ ensure that the correct client-server +protocol is used. + +In its simplest guise, this technique simply employs the compiler to ensure +that our clients only communicate with us in well-known ways. Let's take a +look at this in action, revisiting the well-trodden _math server_ example +from our previous tutorials: + +{% highlight haskell %} +module MathServer + ( -- client facing API + MathServer() + , add + -- starting/spawning the server process + , launchMathServer + ) where + +import .... -- elided + +newtype MathServer = MathServer { mathServerPid :: ProcessId } + deriving (Typeable) + +-- other types/details elided + +add :: MathServer -> Double -> Double -> Process Double +add MathServer{..} = call mathServerPid . Add + +launchMathServer :: Process MathServer +launchMathServer = launch >>= return . MathServer + where launch = + let server = statelessProcess { + apiHandlers = [ handleCall_ (\(Add x y) -> return (x + y)) ] + , unhandledMessagePolicy = Drop + } + in spawnLocal $ start () (statelessInit Infinity) server >> return () +{% endhighlight %} + +What we've changed here is the _handle_ clients use to communicate with the +process, hiding the `ProcessId` behind a newtype and forcing client code to +use the `MathServer` handle to call our API functions. Since the `MathServer` +newtype wraps a `ProcessId`, it is `Serializable` and can be sent to remote +clients if needed. + +------ +> ![Warning: ][alert] Note that we _still_ cannot assume that no _info messages_ +> will arrive in our mailbox, since it is _impossible_ to guarantee our `ProcessId` +> will remain private due to the presence of the [management][mgmt] and +> [tracing/debugging][dbg] APIs in distributed-process. Servers that use the +> distributed-process monitoring APIs, must also be prepared to deal with monitor +> signals (such as the ubiquitous `ProcessMonitorNotification`) arriving as _info +> messages_, since these are always dispatched directly to our mailbox via the +> node controller. +------ + +Another reason to use a _server handle_ like this, instead of a raw `ProcessId`, +is to ensure type compatibility between client and server, in cases where the +server has been written to generically deal with various types whilst the client +needs to reify its calls/casts over a specific type. To demonstrate this +approach, we'll consider the [`Registry`][1] module, which provides an enhanced +_process registry_ that provides name registration services and also behaves +like a per-process, global key-value store. + +Each `Registry` server deals with specific types of keys and values. Allowing +clients to send and receive instructions pertaining to a registry server without +knowing the exact types the server was _spawned_ to handle, is a recipe for +disaster, since the client is very likely to block indefinitely if the expected +request types don't match up, since the server will ignore them. +We can alleviate this problem using phantom type parameters, storing only +the real `ProcessId` we need to communicate with the server, whilst utilising +the compiler to ensure the correct types are assumed at both ends. + +{% highlight haskell %} +data Registry k v = Registry { registryPid :: ProcessId } + deriving (Typeable, Generic, Show, Eq) +instance (Keyable k, Serializable v) => Binary (Registry k v) where +{% endhighlight %} + +In order to start our registry, we need to know the specific `k` and `v` types, +but we do not real values of these, so we use scoped type variables to reify +them when creating the `Registry` handle: + +{% highlight haskell %} +start :: forall k v. (Keyable k, Serializable v) => Process (Registry k v) +start = return . Registry =<< spawnLocal (run (undefined :: Registry k v)) + +run :: forall k v. (Keyable k, Serializable v) => Registry k v -> Process () +run _ = + MP.pserve () (const $ return $ InitOk initState Infinity) serverDefinition + -- etc.... +{% endhighlight %} + +Having wrapped the `ProcessId` in a newtype that ensures the types with which +the server was initialised are respected by clients, we use the same approach +as earlier to force clients of our API to interact with the server not only +using the requisite call/cast protocol, but also providing the correct types +in the form of a valid handle. + +{% highlight haskell %} +addProperty :: (Keyable k, Serializable v) + => Registry k v -> k -> v -> Process RegisterKeyReply +addProperty reg k v = .... +{% endhighlight %} + +So long as we only expose `Registry` newtype construction via our `start` API, +clients cannot forge a registry handle and both client and server can rely on +the compiler to have enforced the correct types for all our interactions. + +------ +> ![Info: ][info] Forcing users to interact with your process via an opaque +> handle is a good habbit to get into, as is hiding the `ProcessId` where +> possible. Use phantom types along with these _server handles_, to ensure +> clients do not send unexpected data to the server. +------ + +Of course, you might actually _need_ the server's `ProcessId` sometimes, +perhaps for monitoring, name registration or similar schemes that operate +explicitly on a `ProcessId`. It is also common to _need_ support for sending +info messages. Some APIs are built on "plain old messaging" via `send` and +therefore completely hiding your `ProcessId` becomes the right way to expose +an API to your clients, but the wrong way to expose your process to other APIs +it is utilising. + +In these situations, the [`Resolvable`][rsbl] and [`Routable`][rtbl] typeclasses +are your friend. By providing a `Resolvable` instance, you can expose your +`ProcessId` to peers that really need it, whilst documenting (via the design +decision to only expose the `ProcessId` via a typeclass) the need to use the +handle in client code. + +{% highlight haskell %} +instance Resolvable (Registry k v) where + resolve = return . Just . registryPid +{% endhighlight %} + +The [`Routable`][rtbl] typeclass provides a means to dispatch messages without +having to know the implementation details behind the scenes. This provides us +with a means for APIs that need to send messages directly to our process to do +so via the opaque handle, without us exposing the `ProcessId` to them directly. +(Of course, such APIs have to be written with [`Routable`][rtbl] in mind!) + +There is a default (and fairly efficient) instance of [`Routable`][rtbl] for all +[`Resolvable`][rsbl] instances, so it is usually enough to implement the latter. +An explicit implementation for our `Registry` would look like this: + +{% highlight haskell %} +instance Routable (Registry k v) where + sendTo reg msg = send (registryPid reg) msg + unsafeSendTo reg msg = unsafeSend (registryPid reg) msg +{% endhighlight %} + +Similar typeclasses are provided for the many occaisions when you need to link +to or kill a process without knowing its `ProcessId`: + +{% highlight haskell %} +class Linkable a where + -- | Create a /link/ with the supplied object. + linkTo :: a -> Process () + +class Killable a where + killProc :: a -> String -> Process () + exitProc :: (Serializable m) => a -> m -> Process () +{% endhighlight %} + +Again, there are default instances of both typeclasses for all [`Resolvable`][rsbl] +types, so it is enough to provide just that instance for your handles. + +### Using Typed Channels + +Typed Channels can be used in two ways via the managed process API, either as +inputs to the server or as a _reply channel_ for RPC style interactions that +offer an alternative to using `call`. + +#### Reply Channels + +When using the `call` API, the server can reply with a datum that doesn't +match the type(s) the client expects. This will cause the client to either +deadlock or timeout, depending on which variant of `call` was used. This isn't +usually a problem, since the server author also writes the client facing API(s) +and can therefore carefully check that the correct types are being returned. +That's still potentially error prone however, and using a `SendPort` as a reply +channel can make it easier to spot potential type discrepancies. + +The machinery behind _reply channels_ is very simple: We create a new channel +for the reply and pass the `SendPort` to the server along with our input message. +The server is responsible for sending its reply to the given `SendPort` and the +corresponding `ReceivePort` is returned so the caller can wait on it. For course, +if no corresponding handler is present in the server definition, there may be no +reply (and depending on the server's `unhandledMessagePolicy`, we may crash the +server). + +------ +> ![Warning: ][alert] Using typed _reply channels_ does not guarantee against +> type mismatches! The server might not recognise the message type or the type +> of the reply channel, in which case the message will be considered an _unhandled_ +> input and dealt with accordingly. +------ + +Typed channels are better suited to handling deferred client-server RPC calls +than plain inter-process messaging too. The only non-blocking `call` API is based +on [`Async`][2] and its only failure mode is an `AsyncFailed` result containing +a corresponding `ExitReason`. The `callTimeout` API is equally limited, since +once its delay is exceeded (and the call times out), you cannot subsequently +retry listening for the message - the client is on its own at this point, and +has to deal with potentially stray (and un-ordered!) replies using the low +level `flushPendingCalls` API. By using a typed channel for replies, we can avoid +both these issues since after the RPC is initiated, the client can defer obtaining +a reply from the `ReceivePort` until it's ready, timeout waiting for the reply +**and** try again at a later time and even wait on the results of multiple RPC +calls (to one or _more_ servers) at the same by merging the ports. + +If we wish to block and wait for a reply immediately (just as we would with `call`), +two blocking operations are provided to simplify the task, one of which returns an +`ExitReason` on failure, whilst the other crashes (with the given `ExitReason` of +course!). The implementation is precisely what you'd expect a blocking _call_ to +do, right up to monitoring the server for potential exit signals (so as not to +deadlock the client if the server dies before replying) - all of which is handled +by `awaitResponse` in the platform's `Primitives` module. + +{% highlight haskell %} +syncSafeCallChan server msg = do + rp <- callChan server msg + awaitResponse server [ matchChan rp (return . Right) ] +{% endhighlight %} + +This might sound like a vast improvement on the usual combination of a client +API that uses `call` and a corresponding `handleCall` in the process definition, +with the programmer left to ensure the types always match up. In reality, there +is a trade-off to be made however. Using the `handleCall` APIs means that our server +side code can use the fluent server API for state changes, immediate replies and +so on. None of these features will work with the corollary family of +`handleRpcChan` functions. Whether or not the difference is merely aesthetic, we +leave as a question for the reader to determine. The following example demonstrates +the use of reply channels: + +{% highlight haskell %} +-- two versions of the same handler, one for calls, one for typed (reply) channels + +data State +data Input +data Output + +-- typeable and binary instances ommitted for brevity + +-- client code + +callDemo :: ProcessId -> Process Output +callDemo server = call server Input + +chanDemo :: ProcessId -> Process Output +chanDemo server = syncCallChan server Input + +-- server code (process definition ommitted for brevity) + +callHandler :: Dispatcher State +callHandler = handleCall $ \state Input -> reply Output state + +chanHandler :: Dispatcher State +chanHandler = handleRpcChan $ \state port Input -> replyChan port Output >> continue state +{% endhighlight %} + +------ +> ![Info: ][info] Using typed channels for replies is both flexible and efficient. +> The trade-off is that you must remember to send a reply from the server explicitly, +> whereas the `call` API forces you to decide how to respond (to the client) via the +> `ProcessReply` type which server-side call _handlers_ have to evaluate to. +------ + +#### Input (Control) Channels + +An alternative input plane managed process servers; _Control Channels_ provide a +number of benefits above and beyond both the standard `call` and `cast` APIs and the +use of reply channels. These include efficiency - _typed channels_ are very lightweight +constructs in general! - and type safety, as well as giving the server the ability to +prioritise information sent on control channels over other traffic. + +Using typed channels as inputs to your managed process is _the_ most efficient way +to enable client-server communication, particularly for intra-node traffic, due to +their internal use of STM (and in particular, its use during selective receives). +Control channels can provide an alternative to prioritised process definitions, since +their use of channels ensures that, providing the control channel handler(s) occur +in the process definition's `apiHandlers` list before the other dispatchers, any +messages received on those channels will be prioritised over other traffic. This is +the most efficient kind of prioritisation - not much use if you need to prioritise +_info messages_ of course, but very useful if _control messages_ need to be given +priority over other inputs. + +------ +> ![Warning: ][alert] Control channels are **not** compatible with prioritised +> process definitions! The type system does not prevent them from being declared +> though, since they _are_ represented by a `Dispatcher` and therefore deemded +> valid entries of the `apiHandlers` field. Upon startup, a prioritised process +> definition that contains control channel dispatchers in its `apiHandlers` will +> immediately exit with the reason `ExitOther "IllegalControlChannel"` though. +------ + +In order to use a typed channel as an input plane, it is necessary to _leak_ the +`SendPort` to your clients somehow. One way would be to `send` it on demand, but the +simplest approach is actually to initialise a handle with all the relevant send ports +and return this to the spawning process via a private channel, MVar or STM (or similar). +Because a `SendPort` is `Serializable`, forwarding them (or the handle they're +contained within) is no problem either. + +Since typed channels are a one way street, there's no direct API support for RPC calls +when using them to send data to a server. The work-around for this remains simple, +type-safe and elegant though: we encode a reply channel into our command/request datum +so the server knows where (and with what type) to reply. This does increase the amount +of boilerplate code the client-facing API has to endure, but it's a small price to pay +for the efficiency and additional type safety provided. + +First, we'll look at an example of a single control channel being used with the +`chanServe` API. This handles the messy details of passing the control channel back +to the calling process, at least to some extent. For this example, we'll examine the +[`Mailbox`][mailbox] module, since this combines a fire-and-forget control channel with +an opaque server handle. + +{% highlight haskell %} +-- our handle is fairly simple +data Mailbox = Mailbox { pid :: !ProcessId + , cchan :: !(ControlPort ControlMessage) + } deriving (Typeable, Generic, Eq) +instance Binary Mailbox where + +instance Linkable Mailbox where + linkTo = link . pid + +instance Resolvable Mailbox where + resolve = return . Just . pid + +-- lots of details elided.... + +-- Starting the mailbox involves both spawning, and passing back the process id, +-- plus we need to get our hands on a control port for the control channel! + +doStartMailbox :: Maybe SupervisorPid + -> ProcessId + -> BufferType + -> Limit + -> Process Mailbox +doStartMailbox mSp p b l = do + bchan <- liftIO $ newBroadcastTChanIO + rchan <- liftIO $ atomically $ dupTChan bchan + spawnLocal (maybeLink mSp >> runMailbox bchan p b l) >>= \pid -> do + cc <- liftIO $ atomically $ readTChan rchan + return $ Mailbox pid cc -- return our opaque handle! + where + maybeLink Nothing = return () + maybeLink (Just p') = link p' + +runMailbox :: TChan (ControlPort ControlMessage) + -> ProcessId + -> BufferType + -> Limit + -> Process () +runMailbox tc pid buffT maxSz = do + link pid + tc' <- liftIO $ atomically $ dupTChan tc + MP.chanServe (pid, buffT, maxSz) (mboxInit tc') (processDefinition pid tc) + +mboxInit :: TChan (ControlPort ControlMessage) + -> InitHandler (ProcessId, BufferType, Limit) State +mboxInit tc (pid, buffT, maxSz) = do + cc <- liftIO $ atomically $ readTChan tc + return $ InitOk (State Seq.empty $ defaultState buffT maxSz pid cc) Infinity + +processDefinition :: ProcessId + -> TChan (ControlPort ControlMessage) + -> ControlChannel ControlMessage + -> Process (ProcessDefinition State) +processDefinition pid tc cc = do + liftIO $ atomically $ writeTChan tc $ channelControlPort cc + return $ defaultProcess { apiHandlers = [ + handleControlChan cc handleControlMessages + , Restricted.handleCall handleGetStats + ] + , infoHandlers = [ handleInfo handlePost + , handleRaw handleRawInputs ] + , unhandledMessagePolicy = DeadLetter pid + } :: Process (ProcessDefinition State) +{% endhighlight %} + +Since the rest of the mailbox initialisation code is quite complex, we'll leave it +there for now. The important details to take away are the use of `chanServe` +and its requirement for a thunk that initialises the `ProcessDefinition`, so it can +perform IO - a pre-requisite to sharing the control channels with the spawning process, +which must use STM or something similar in order to share data with the newly spawned +server's initialisation code. In our case, we want to pass the control port from the +thunk passed to `chanServe` back to both the spawning process _and_ the init function +(which is normally de-coupled from the initialising thunk), which makes this a good +example of how to utilise a broadcast TChan (or TQueue) to share control plane +structures during initialisation. + +------ + +Now we'll cook up another (contrived) example that uses multiple typed control channels, +demonstrating how to create control channels explicitly, how to obtain a `ControlPort` +for each one, one way of passing these back to the process spawning the server (so as +to fill in the opaque server handle) and how to utilise these in your client code, +complete with the use of typed reply channels. This code will not use `chanServe`, +since _that_ API only supports a single control channel - the original purpose behind +the control channel concept - and instead, we'll create the process loop ourselves, +using the exported low level `recvLoop` function. + +{% highlight haskell %} + +type NumRequests = Int + +data EchoServer = EchoServer { echoRequests :: ControlPort String + , statRequests :: ControlPort NumRequests + , serverPid :: ProcessId + } + deriving (Typeable, Generic) +instance Binary EchoServer where +instance NFData EchoServer where + +instance Resolvable EchoServer where + resolve = return . Just . serverPid + +instance Linkable EchoServer where + linkTo = link . serverPid + +-- The server takes a String and returns it verbatim + +data EchoRequest = EchoReq !String !(SendPort String) + deriving (Typeable, Generic) +instance Binary EchoRequest where +instance NFData EchoRequest where + +data StatsRequest = StatsReq !(SendPort Int) + deriving (Typeable, Generic) +instance Binary StatsRequest where +instance NFData StatsRequest where + +-- client code + +echo :: EchoServer -> String -> Process String +echo h s = do + (sp, rp) <- newChan + let req = EchoReq s sp + sendControlMessage (echoRequests h) req + receiveWait [ matchChan rp return ] + +stats :: EchoServer -> Process NumRequests +stats h = do + (sp, rp) <- newChan + let req = StatsReq sp + sendControlMessage (statRequests h) req + receiveWait [ matchChan rp return ] + +demo :: Process () +demo = do + server <- spawnEchoServer + foobar <- echo server "foobar" + foobar `shouldBe` equalTo "foobar" + + baz <- echo server "baz" + baz `shouldBe` equalTo baz + + count <- stats server + count `shouldBe` equalTo (2 :: NumRequests) + +-- server code + +spawnEchoServer :: Process EchoServer +spawnEchoServer = do + (sp, rp) <- newChan + pid <- spawnLocal $ runEchoServer sp + (echoPort, statsPort) <- receiveChan rp + return $ EchoServer echoPort statsPort pid + +runEchoServer :: SendPort (ControlPort EchoRequest, ControlPort StatsRequest) + -> Process () +runEchoServer portsChan = do + echoChan <- newControlChan + echoPort <- channelControlPort echoChan + statChan <- newControlChan + statPort <- channelControlPort statChan + sendChan portsChan (echoPort, statPort) + runProcess (recvLoop $ echoServerDefinition echoChan statChan ) echoServerInit + +echoServerInit :: InitHandler () NumRequests +echoServerInit = return $ InitOk (0 :: Int) Infinity + +echoServerDefinition :: ControlChannel EchoRequest + -> ControlChannel StatsRequest + -> ProcessDefinition NumRequests +echoServerDefinition echoChan statChan = + defaultProcess { + apiHandlers = [ handleControlChan echoChan handleEcho + , handleControlChan statChan handleStats + ] + } + +handleEcho :: NumRequests -> EchoRequest -> Process (ProcessAction State) +handleEcho count (EchoReq req replyTo) = do + replyChan replyTo req -- echo back the string + continue $ count + 1 + +handleStats :: NumRequests -> StatsRequest -> Process (ProcessAction State) +handleStats count (StatsReq replyTo) = do + replyChan replyTo count + continue count +{% endhighlight %} + +Although not very useful, this is a working example. Note that the client must +deal with a `ControlPort` and not the complete `ControlChannel` itself. Also +note that the server is completely responsible for replying (explicitly) to +the client using the send ports supplied in the request data. + +------ +> ![Info: ][info] Combining control channels with opaque handles is another great +> way to enforce additional type safety, since the channels must be initialised by +> the server code before it can create handlers for them and the client code that +> passes data to them (via the `SendPort`) is bound to exactly the same type(s)! +> Furthermore, adding reply channels (in the form of a `SendPort`) to the request +> types ensures that the replies will be handled correctly as well! As a result, +> there can be no ambiguity about the types involved for _either_ side of the +> client-server relationship and therefore no unhandled messages due to runtime +> type mismatches - the compiler will catch that sort of thing for us! +------ + +[1]: https://hackage.haskell.org/package/distributed-process-registry/docs/Control-Distributed-Process-Registry.html +[2]: https://hackage.haskell.org/package/distributed-process-async/docs/Control-Distributed-Process-Async.html +[3]: https://hackage.haskell.org/package/distributed-process-extras/docs/Control-Distributed-Process-Extras-SystemLog.html +[mgmt]: https://hackage.haskell.org/package/distributed-process/Control-Distributed-Process-Management.html +[dbg]: https://hackage.haskell.org/package/distributed-process/Control-Distributed-Process-Debug.html +[rtbl]: https://hackage.haskell.org/package/distributed-process-extras/docs/Control-Distributed-Process-Extras.html#t:Routable +[rsbl]: https://hackage.haskell.org/package/distributed-process-extras/docs/Control-Distributed-Process-Extras.html#t:Resolvable +[alert]: /img/alert.png +[info]: /img/info.png +[policy]: https://hackage.haskell.org/package/distributed-process-client-server/docs/Control-Distributed-Process-ManagedProcess.html#v:unhandledMessagePolicy +[mailbox]: https://hackage.haskell.org/package/distributed-process-execution-0.1.2.2/docs/Control-Distributed-Process-Execution-Mailbox.html diff --git a/website/tutorials/tutorial-NT2.md b/website/tutorials/tutorial-NT2.md new file mode 100644 index 00000000..fabcd406 --- /dev/null +++ b/website/tutorials/tutorial-NT2.md @@ -0,0 +1,295 @@ +--- +layout: tutorial2 +categories: tutorial +title: Programming with Network.Transport +--- + +### Introduction + +This is a tutorial introduction to `Network.Transport`. To follow along, +you should probably already be familiar with `Control.Concurrent`; in +particular, the use of `fork` and `MVar`s. The code for the tutorial can +be downloaded as [tutorial-server.hs](/static/tutorial/tutorial-server.hs) +and [tutorial-client.hs](/static/tutorial/tutorial-client.hs). + +------- + +### The Network Transport API + +Network.Transport is a network abstraction layer which offers the following concepts: + +* Nodes in the network are represented by `EndPoint`s. These are heavyweight stateful objects. +* Each `EndPoint` has an `EndPointAddress`. +* Connections can be established from one `EndPoint` to another using the `EndPointAddress` of the remote end. +* The `EndPointAddress` can be serialised and sent over the network, where as `EndPoint`s and connections cannot. +* Connections between `EndPoint`s are unidirectional and lightweight. +* Outgoing messages are sent via a `Connection` object that represents the sending end of the connection. +* Incoming messages for **all** of the incoming connections on an `EndPoint` are collected via a shared receive queue. +* In addition to incoming messages, `EndPoint`s are notified of other `Event`s such as new connections or broken connections. + +In this tutorial we will create a simple "echo" server. Whenever a client +opens a new connection to the server, the server in turns opens a connection +back to the client. All messages that the client sends to the server will +echoed by the server back to the client. + +Here is what it will look like. We can start the server on one host: + +{% highlight bash %} +# ./tutorial-server 192.168.1.108 8080 +Echo server started at "192.168.1.108:8080:0" +{% endhighlight %} + +then start the client on another. The client opens a connection to the server, +sends "Hello world", and prints all the `Events` it receives: + +{% highlight bash %} +# ./tutorial-client 192.168.1.109 8080 192.168.1.108:8080:0 +ConnectionOpened 1024 ReliableOrdered "192.168.1.108:8080:0" +Received 1024 ["Hello world"] +ConnectionClosed 1024 +{% endhighlight %} + +The client receives three `Event`s: + +1. The server (with address "192.168.1.108:8080:0") opened a connection back to the client. The ID of this connection is 1024, and the connection is reliable and ordered (see below). +2. Received a message on connection 1024: that is, on the connection the server just opened. This is the server echoing the message we sent. +3. Connection 1024 was closed. + +Note that the server prints its address ("192.168.1.108:8080:0") to the +console when started and this must be passed explicitly as an argument to +the client. Peer discovery and related issues are outside the scope of +`Network.Transport`. + +### Writing the client + +We will start with the client +([tutorial-client.hs](https://github.com/haskell-distributed/distributed-process/blob/master/doc/tutorial/tutorial-client.hs)), +because it is simpler. We first need a bunch of imports: + +{% highlight haskell %} +import Network.Transport +import Network.Transport.TCP (createTransport, defaultTCPParameters) +import Network.Socket.Internal (withSocketsDo) +import System.Environment +import Data.ByteString.Char8 +import Control.Monad +{% endhighlight %} + +The client will consist of a single main function. [withSocketsDo](http://hackage.haskell.org/package/network-2.6.2.1/docs/Network-Socket-Internal.html#v:withSocketsDo) may be needed for Windows platform with old versions of network library. For compatibility with older versions on Windows, it is good practice to always call withSocketsDo (it's very cheap). + +{% highlight haskell %} +main :: IO () +main = withSocketsDo $ do +{% endhighlight %} + +When we start the client we expect three command line arguments. +Since the client will itself be a network endpoint, we need to know the IP +address and port number to use for the client. Moreover, we need to know the +endpoint address of the server (the server will print this address to the +console when it is started): + +{% highlight haskell %} +[host, port, serverAddr] <- getArgs +{% endhighlight %} + +Next we need to initialize the Network.Transport layer using `createTransport` +from `Network.Transport.TCP` (in this tutorial we will use the TCP instance of +`Network.Transport`). The type of `createTransport` is: + +{% highlight haskell %} +createTransport :: N.HostName -> N.ServiceName -> IO (Either IOException Transport) +{% endhighlight %} + +(where `N` is an alias for `Network.Socket`). For the sake of this tutorial we +are going to ignore all error handling, so we are going to assume it will return +a `Right` transport: + +{% highlight haskell %} +Right transport <- createTransport host port +{% endhighlight %} + +Next we need to create an EndPoint for the client. Again, we are going +to ignore errors: + +{% highlight haskell %} +Right endpoint <- newEndPoint transport +{% endhighlight %} + +Now that we have an endpoint we can connect to the server, after we convert +the `String` we got from `getArgs` to an `EndPointAddress`: + +{% highlight haskell %} +let addr = EndPointAddress (pack serverAddr) +Right conn <- connect endpoint addr ReliableOrdered defaultConnectHints +{% endhighlight %} + +`ReliableOrdered` means that the connection will be reliable (no messages will be +lost) and ordered (messages will arrive in order). For the case of the TCP transport +this makes no difference (_all_ connections are reliable and ordered), but this may +not be true for other transports. + +Sending on our new connection is very easy: + +{% highlight haskell %} +send conn [pack "Hello world"] +{% endhighlight %} + +(`send` takes as argument an array of `ByteString`s). +Finally, we can close the connection: + +{% highlight haskell %} +close conn +{% endhighlight %} + +Function `receive` can be used to get the next event from an endpoint. To print the +first three events, we can do + +{% highlight haskell %} +replicateM_ 3 $ receive endpoint >>= print +{% endhighlight %} + +Since we're not expecting more than 3 events, we can now close the transport. + +{% highlight haskell %} +closeTransport transport +{% endhighlight %} + +That's it! Here is the entire client again: + +{% highlight haskell %} +main :: IO () +main = withSocketsDo $ do + [host, port, serverAddr] <- getArgs + Right transport <- createTransport host port + Right endpoint <- newEndPoint transport + + let addr = EndPointAddress (pack serverAddr) + Right conn <- connect endpoint addr ReliableOrdered defaultConnectHints + send conn [pack "Hello world"] + close conn + + replicateM_ 3 $ receive endpoint >>= print + + closeTransport transport +{% endhighlight %} + +### Writing the server + +The server ([tutorial-server.hs](https://github.com/haskell-distributed/distributed-process/blob/master/doc/tutorial/tutorial-server.hs)) +is slightly more complicated, but only slightly. As with the client, we +start with a bunch of imports: + +{% highlight haskell %} +import Network.Transport +import Network.Transport.TCP (createTransport, defaultTCPParameters) +import Network.Socket.Internal (withSocketsDo) +import Control.Concurrent +import Data.Map +import Control.Exception +import System.Environment +{% endhighlight %} + +We will write the main function first: + +{% highlight haskell %} +main :: IO () +main = withSocketsDo $ do + [host, port] <- getArgs + serverDone <- newEmptyMVar + Right transport <- createTransport host port defaultTCPParameters + Right endpoint <- newEndPoint transport + forkIO $ echoServer endpoint serverDone + putStrLn $ "Echo server started at " ++ show (address endpoint) + readMVar serverDone `onCtrlC` closeTransport transport +{% endhighlight %} + +This is very similar to the `main` function for the client. We get the +hostname and port number that the server should use and create a transport +and an endpoint. Then we fork a thread to do the real work. We will write +`echoServer` next; for now, suffices to note that `echoServer` will signal +on the MVar `serverDone` when it completes, so that the main thread knows +when to exit. Don't worry about `onCtrlC` for now; it does what the +name suggests. + +The goal of `echoServer` is simple: whenever somebody opens a connection to us, +open a connection to them; whenever somebody sends us a message, echo that message; +and whenever somebody closes their connection to us, we are going to close +our connection to them. + +`Event` is defined in `Network.Transport` as + +{% highlight haskell %} +data Event = + Received ConnectionId [ByteString] + | ConnectionClosed ConnectionId + | ConnectionOpened ConnectionId Reliability EndPointAddress + | EndPointClosed + ... +{% endhighlight %} + +(there are few other events, which we are going to ignore). `ConnectionId`s help us +distinguish messages sent on one connection from messages sent on another. In +`echoServer` we are going to maintain a mapping from those `ConnectionId`s to the +connections that we will use to reply: + +* Whenever somebody opens a connection, we open a connection in the other direction and add it to the map. +* Whenever we receive a message, we lookup the corresponding return connection and echo the message back. +* Whenever somebody closes the connection, we lookup and close the corresponding return connection. + +Finally, when we receive the `EndPointClosed` message we signal to the main +thread that we are doing and terminate. We will receive this message when the +main thread calls `closeTransport` (that is, when the user presses Control-C). + +{% highlight haskell %} +echoServer :: EndPoint -> MVar () -> IO () +echoServer endpoint serverDone = go empty + where + go :: Map ConnectionId (MVar Connection) -> IO () + go cs = do + event <- receive endpoint + case event of + ConnectionOpened cid rel addr -> do + connMVar <- newEmptyMVar + forkIO $ do + Right conn <- connect endpoint addr rel defaultConnectHints + putMVar connMVar conn + go (insert cid connMVar cs) + Received cid payload -> do + forkIO $ do + conn <- readMVar (cs ! cid) + send conn payload + return () + go cs + ConnectionClosed cid -> do + forkIO $ do + conn <- readMVar (cs ! cid) + close conn + go (delete cid cs) + EndPointClosed -> do + putStrLn "Echo server exiting" + putMVar serverDone () +{% endhighlight %} + +This implements almost exactly what we described above. The only complication is that we want to avoid blocking the receive queue; so for every message that comes in we spawn a new thread to deal with it. Since is therefore possible that we receive the `Received` event before an outgoing connection has been established, we map connection IDs to MVars containing connections. + +Finally, we need to define `onCtrlC`; `p onCtrlC q` will run `p`; if this is interrupted by Control-C we run `q` and then try again: + +{% highlight haskell %} +onCtrlC :: IO a -> IO () -> IO a +p `onCtrlC` q = catchJust isUserInterrupt p (const $ q >> p `onCtrlC` q) + where + isUserInterrupt :: AsyncException -> Maybe () + isUserInterrupt UserInterrupt = Just () + isUserInterrupt _ = Nothing +{% endhighlight %} + +### Conclusion + +In this tutorial, we have implemented a small echo client and server +to illustrate how the `Network.Transport` abstraction layer can be used. + + + +See the [`Network.Transport` wiki page](https://github.com/haskell-distributed/distributed-process/wiki/Network.Transport) for more details. + + diff --git a/website/wiki.md b/website/wiki.md new file mode 100644 index 00000000..675dedec --- /dev/null +++ b/website/wiki.md @@ -0,0 +1,33 @@ +--- +layout: wiki +title: Cloud Haskell Wiki +wiki: Welcome +--- + +### Welcome + +Welcome to the Cloud Haskell Wiki. Navigate to specific pages using the links +on the left. If you wish to edit or add to the pages in this wiki, read on. + +### Editing + +Editing the wiki is pretty simple. This entire website is stored in a git +repository and its dynamic content rendered by github pages using [Jekyll][1]. +You can clone the repository [here][2]. Instructions for using jekyll are +available [online][1], but in general it's just a matter of finding the right +markdown file. Wiki content is all located in the wiki subfolder. + +### Adding new content + +New wiki pages need to have some specific fields in their [Yaml Front Matter][3]. +There is a makefile in the root directory which will create a wiki page for +you (in the wiki directory) and populate the front matter for you. Calling the +makefile is pretty easy. + +{% highlight bash %} +make wikipage NAME= +{% endhighlight %} + +[1]: https://github.com/mojombo/jekyll +[2]: https://github.com/haskell-distributed/haskell-distributed.github.com +[3]: https://github.com/mojombo/jekyll/wiki/YAML-Front-Matter diff --git a/website/wiki/contributing.md b/website/wiki/contributing.md new file mode 100644 index 00000000..66122071 --- /dev/null +++ b/website/wiki/contributing.md @@ -0,0 +1,245 @@ +--- +layout: wiki +title: Contributor Guide +wiki: contributing +--- + +# Contributing + +Community contributions are most welcome! These should be submitted via Github's +*pull request* mechanism. Following the guidelines described here will ensure +that pull requests require a minimum of effort to deal with, hopefully +allowing the maintainer who is merging your changes to focus on the substance +of the patch rather than stylistic concerns and/or handling merge conflicts. + +This document is quite long, but don't let that put you off! Most of the things +we're saying here are just common sense and none of them is hard to follow. + +With this in mind, please try to observe the following guidelines when +submitting patches. + +## Common Repository Format and Git Branches + +All Cloud Haskell repositories should conform to a common structure, with the +exception of website and/or documentation projects. The structure is basically +that of a cabal library or executable project, with a couple of additional files. + +``` +- project-name + - project-name.cabal + - Makefile + - LICENCE + - README.md + - src/ + - tests/ + - benchmarks/ + - examples/ + - regressions/ +``` + +All repositories must use the same git branch structure: + +* ongoing development takes place on the `master` branch +* the code that goes into a release must be tagged as soon as it is uploaded to hackage +* each release tag must then get its own release-x.y.z branch, branched from the tagged commit +* after a release, the *release branch* is not merged back into `master` +* patches can be submitted via branches off `master`, or from a `release-x.y.z` branch +* features and bug-fixes that are compatible with `master` can be merged in directly +* interim bug-fixes we **don't** want included (i.e., bug-fix only releases) + * are merged into a new release-x.y.z branch (taken from the prior release branch) instead + * these can, but do not have to be, merged into `master` + +### __1. Check to see if your patch is likely to be accepted__ + +We have a rather full backlog, so your help will be most welcome assisting +us in clearing that. You can view the exiting open issues on +[github](https://github.com/haskell-distributed). + +It is also helpful to work out which component or sub-system should be +changed. You may wish to email the maintainers to discuss this first. + +### __2. Make sure your patch merges cleanly__ + +Working through pull requests is time consuming and this project is entirely +staffed by volunteers. Please make sure your pull requests merge cleanly +whenever possible, so as to avoid wasting everyone's time. + +The best way to achieve this is to fork the main repository on github, and then +make your changes in a local branch. Before submitting your pull request, fetch +and rebase any changes to the upstream source branch and merge these into your +local branch. For example: + +{% highlight bash %} +## on your local repository, create a branch to work in + +$ git checkout -b bugfix-issue123 + +## add and commit your changes +## base them on master for bugfixes or development for new features + +$ git checkout master +$ git remote add upstream git://github.com/haskell-distributed/distributed-process.git +$ git fetch upstream +$ git rebase upstream/master + +## and now rebase (or merge) against your work + +$ git checkout bugfix-issue123 +$ git merge master + +## make sure you resolve any merge conflicts +## and commit before sending a pull request! +{% endhighlight %} + +### __3. Follow the patch submission *rules of thumb*__ + +These are pretty simple and are mostly cribbed from the GHC wiki's git working +conventions page [here](http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions/Git). + +1. try to make small patches - the bigger they are, the longer the pull request QA process will take +2. strictly separate all changes that affect functionality from those that just affect code layout, indentation, whitespace, filenames etc +3. always include the issue number (of the form `PROJECT_CODE #resolve Fixed`) in the final commit message for the patch - pull requests without an issue are unlikely to have been discussed (see above) +4. use Unix conventions for line endings. If you are on Windows, ensure that git handles line-endings sanely by running `git config --global core.autocrlf false` +5. make sure you have setup git to use the correct name and email for your commits - see the [github help guide](https://help.github.com/articles/setting-your-email-in-git) - otherwise you won't be attributed in the scm history! + +### __4. Make sure all the tests pass__ + +If there are any failing tests then your pull request will not be merged. Please +don't rely on the maintainers to deal with these, unless of course the tests are +failing already on the branch you've diverged from. In that case, please submit +an issue so that we can fix the failing tests asap! + +### __5. Try to eliminate compiler warnings__ + +Code should be compilable with `-Wall -Werror`. There should be no +warnings. We *may* make some exceptions to this rule, but pull requests that +contain multitudinous compiler warnings will take longer to QA. + +### __6. Always branch from the right place__ + +Please be aware of whether or not your changes are actually a bugfix or a new +feature, and branch from the right place accordingly. The general rule is: + +* new features should branch off `master` +* bug fixes can branch off `master` or a `release-x.y.z` branch + +If you branch from the wrong place then you will be asked to rework your changes +so try to get this right in the first place. If you're unsure whether a patch +should be considered a feature or a bug-fix then discuss this when opening a new +github issue. + +### General Style + +A lot of this **is** taken from the GHC Coding Style entry [here](http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle). +In particular, please follow **all** the advice on that wiki page when it comes +to including comments in your code. + +I am also grateful to @tibbe for his +[haskell-style-guide](https://github.com/tibbe/haskell-style-guide), from +which some of these rules have been taken. + +As a general rule, stick to the same coding style as is already used in the file +you're editing. It **is** much better to write code that is transparent than to +write code that is short. Please don't assume everyone is a minimalist - self +explanatory code is **much** better in the long term than pithy one-liners. +Having said that, we *do* like reusing abstractions where doing so adds to the +clarity of the code as well as minimising repetitious boilerplate. + +### Formatting + +#### Line Length + +Maximum line length is *80 characters*. This might seem antiquated +to you, but some of us do things like github pull-request code +reviews on our mobile devices on the way to work, and long lines +make this horrendously difficult. Besides which, some of us are +also emacs users and have this rule set up for all of our source +code editing modes. + +#### Indentation + +Tabs are illegal. Use **only** spaces for indenting. +Indentation is usually 2 spaces, with 4 spaces used in some places. +We're pretty chilled about this, but try to remain consistent. + +#### Blank Lines + +One blank line between top-level definitions. No blank lines between +type signatures and function definitions. Add one blank line between +functions in a type class instance declaration if the functions bodies +are large. As always, use your judgement. + +#### Whitespace + +Do not introduce trailing whitespace. If you find trailing whitespace, +feel free to strip it out - in a separate commit of course! + +Surround binary operators with a single space on either side. Use +your better judgement for the insertion of spaces around arithmetic +operators but always be consistent about whitespace on either side of +a binary operator. + +#### Alignment + +When it comes to alignment, there's probably a mix of things in the codebase +right now. Personally, I tend not to align import statements as these change +quite frequently and it is pain keeping the indentation consistent. + +The one exception to this is probably imports/exports, which we *are* a +bit finicky about: + +{% highlight haskell %} +import qualified Foo.Bar.Baz as Bz +import Data.Binary + ( Binary (..), + , getWord8 + , putWord8 + ) +import Data.Blah +import Data.Boom (Typeable) +{% endhighlight %} + +We generally don't care *that much* about alignment for other things, +but as always, try to follow the convention in the file you're editing +and don't change things just for the sake of it. + +### Comments + +#### Punctuation + +Write proper sentences; start with a capital letter and use proper +punctuation. + +#### Top-Level Definitions + +Comment every top level function (particularly exported functions), +and provide a type signature; use Haddock syntax in the comments. +Comment every exported data type. Function example: + +{% highlight haskell %} +-- | Send a message on a socket. The socket must be in a connected +-- state. Returns the number of bytes sent. Applications are +-- responsible for ensuring that all data has been sent. +send :: Socket -- ^ Connected socket + -> ByteString -- ^ Data to send + -> IO Int -- ^ Bytes sent +{% endhighlight %} + +For functions, the documentation should give enough information to +apply the function without looking at the function's definition. + +### Naming + +Use `mixedCase` when naming functions and `CamelCase` when naming data +types. + +For readability reasons, don't capitalize all letters when using an +abbreviation. For example, write `HttpServer` instead of +`HTTPServer`. Exception: Two letter abbreviations, e.g. `IO`. + +#### Modules + +Use singular when naming modules e.g. use `Data.Map` and +`Data.ByteString.Internal` instead of `Data.Maps` and +`Data.ByteString.Internals`. + diff --git a/website/wiki/development.md b/website/wiki/development.md new file mode 100644 index 00000000..55b1592c --- /dev/null +++ b/website/wiki/development.md @@ -0,0 +1,54 @@ +--- +layout: wiki +title: Development +wiki: development +--- + +### Development + +This section contains topics that are under development and have not +been formalized and added to formal specification or implemented. + + +#### Registry specification + +*Problem: current specification doesn't cover the semantics of registry +if the remote processes can be put into registry and if we can send +messages to such processes using `nsend`.* + +Here is a prosal for semantics that is summary of the [email thread](https://groups.google.com/forum/?hl=en-GB#!topic/cloud-haskell-developers/120_WugguPg) + +References are the following: + + * Uni - stands for unified semantics for Future Erlang + + * Spec - stands for formal CH specification + + * ML - stands for mailing list + +**Semantics:** + + 1. Registry. + 1. It should be possible to register remote processes in local registry (and local processes in remote registry) + Rationale: [Uni. Sec 2.3] + + 2. If a remote process is stored in registry then Node Controller starts monitoring that process + Rationale: (Implicit requirement in because node should be able to receive notification about process death) + + 3. If a process dies and we get asynchronous notification then we remove process from registry + Rationale: [Uni. Definition 18, Uni. Table 12] + + 2. `nsend` + + 1. `nsend` should be implemented in terms of lower level function `whereis` and `send` + + 2. `nsend` is process does not exists in registry then message got silently dicarded. + + +Possible problems: + +Current proposal opens space for race conditions, we should understand if those are relevant for us, and +could or could not be solved + +a. 2.1 adds a possibility for changing label beetwen where is and send, so message will be + sent to the wrong process. diff --git a/website/wiki/faq.md b/website/wiki/faq.md new file mode 100644 index 00000000..321475f8 --- /dev/null +++ b/website/wiki/faq.md @@ -0,0 +1,35 @@ +--- +layout: wiki +title: FAQ/Getting Help +wiki: FAQ +--- + +### FAQ + +#### Do I need to install a network-transport backend? + +Yes. The `Network.Transport` component provides only the API - an actual +backend that implements this will be required in order to start a CH node. + +#### What guarantees are there for message ordering, sending, etc + +Take a look at the formal semantics for answers to *all* such questions. +They're actually quite pithy and readable, and fairly honest about where +there are still gaps. + +You can find them via the *resources* tab just above this page. + +### Help + +If the documentation doesn't answer your question, queries about Cloud Haskell +can be directed to the Parallel Haskell Mailing List +(parallel-haskell@googlegroups.com), which is pretty active. If you think +you've found a bug, or would like to request a new feature, please visit the +[github](https://github.com/haskell-distributed) repositories and submit a bug. + +### Getting Involved + +If you're interested in hacking Cloud Haskell then please read the +[Contributing](/wiki/contributing.html) wiki page. Additional help can be obtained through the +[Developers Forum/Mailing List](https://groups.google.com/forum/?fromgroups=#!forum/cloud-haskell-developers) +or Parallel Haskell mailing list. diff --git a/website/wiki/maintainers.md b/website/wiki/maintainers.md new file mode 100644 index 00000000..d565456a --- /dev/null +++ b/website/wiki/maintainers.md @@ -0,0 +1,176 @@ +--- +layout: wiki +title: Maintainers +wiki: Maintainers +--- + +### Maintainers + +This part of the guide is specifically for maintainers, and outlines the development +process and in particular, the branching strategy. We also point out Cloud Haskell's +various bits of infrastructure as they stand at the moment. + +Perhaps the most important thing to do as a maintainer, is to make other developers +aware of what you're working on by assigning the github issue to yourself! + +---- +#### Releases + +All releases are published to [hackage][3]. At some point we may start to +make *nightly builds* available on this website. We need some help setting that +up though. + +---- + +#### Community + +We keep in touch through the [parallel-haskell mailing list][5], and once you've +joined the group, by posting to the mailing list address: parallel-haskell@googlegroups.com. +This is a group for **all** things related to concurrent and parallel Haskell. There is +also a maintainer/developer centric [cloud-haskell-developers mailing list][6], which is +more for in-depth questions about contributing to or maintaining Cloud Haskell. + +You might also find some of us hanging out at #haskell-distributed on +freenode from time to time. + +We have a twitter account! [@CloudHaskell](https://twitter.com/CloudHaskell) +will be used to make announcements (of new releases, etc) on a regular basis. + +---- + +### Bug/Issue Tracking and Continuous Integration + +We report issues for each project in [github][1]. +You can browse all issues without logging in, however to report new issues/bugs +you will need to provide an email address and create an account. + +If you have any difficulties doing so, please post an email to the +[parallel-haskell mailing list][5] at parallel-haskell@googlegroups.com. + +We currently use [travis-ci][7] for continuous integration. We do however, +have an open source license for Atlassian Bamboo, which we will be migrating +to over time - this process is quite involved so we don't have a picture of +the timescales yet. + +---- + +### Branching/Merging Policy + +The master branch is the *active development* branch. Small changes can be committed +directly to `master`, or committed to a branche before getting merged. When we're +ready to release, the project is tagged using the format `vX.Y.Z` once it has been +published. Each release then gets its own `release-x.y.z` branch, created from the +tagged commit. These can be used to produce interim/bug-fix releases if necessary. + +A release tag should be of the form `x.y.z` and should **not** be prefixed with the +repository name. Older tags use the latter form as they date from a time when all the +Cloud Haskell source code lived under one git repository. + +Patches should be made against `master` **unless** they represent an interim bug-fix +to a given `release-x-y-z` branch. The latter should be created against the branch +they intend to fix. + +#### Development Branches + +Development should usually take place on a `feature-X` or `bugfix-Y` branch. The +old `development` branch is defunct and will be removed at some point in the future. + +#### Interim and bug-fix only releases + +The complexity around *interim* releases is necessary to deal with situations where we +need to patch a release, but `master` has already moved on, making the patch irrelevant +for the next major release. For example, assuming a project is at version 1.2.3 and we +find a bug in module `Foo.hs`. Users who're on v1.2.3 will want the fix asap for any +production deployments, yet `Foo.hs` has been completely re-written/replaced on `master` +and the bugfix isn't needed there. To support user's who do not wish to wait for v2.0.0 +to be released, we create a `release-1.2.4` branch and merge the bugfix into that, but +we do **not** merge this back into master, since the patch won't apply. +This way, subsequent bug fixes to the 1.2.x series can also continue in parallel with +changes to `master` if necessary. + +What happens if we have a patch for `release-1.2.3` that *is* applicable to master, but +won't apply cleanly due to changes since the release was tagged? In this situation, we +create a bug-fix release branch as usual, into which the patch is merged. A maintainer +will then have to retro-fit the patch so that it can be applied to `master`. This is +a somewhat ugly, since if we wish to create subsequent bug-fixes and create another +1.2.5 branch (viz the example above), we'll may have to manually transplant some changes +from `master` in the process. + +#### Keeping History + +Try to make only clean commits, so that bisect will continue to work. At the same time, +it can be helpful to avoid making destructive updates. If you're planning on doing lots +of squashes, then work in a branch and don't commit directly to `master` until you're +finished and ready to QA and merge. + +#### Committing without triggering CI builds + +Whilst we're on travis-ci, you can do this by putting the text `[ci skip]` anywhere in +the commit message. Please, please **do not** put this on the first line of the commit +message. + +Once we migrate to Bamboo, this may change. + +---- + +#### Follow the Contributing guidelines + +What's good for the goose... + +#### Making API documentation available on the website + +There is an open ticket to set up nightly builds, which will update +the HEAD haddocks (on the website) and produce an 'sdist' bundle and +add that to the website too. + +See https://cloud-haskell.atlassian.net/browse/INFRA-1 for details. + +### Release Process + +First of all, a few prior warnings. **Do not** tag any projects until *after* +you've finished and uploaded the release. If you build and tag three projects, +only to find that a subsequent dependent package needs a bit of last minute +surgery, you'll be sorry you didn't wait. With that in mind.... + +Before releasing any source code, make sure that all the github tickets +added to the release are either resolved or remove them from the +release if you've decided to exclude them. + +First, make sure all the version numbers and dependencies are aligned. + +* bump the version numbers for each project that is being released +* bump the dependency versions across each project if needed +* make sure you've run a complete integration build and everything still installs ok +* bump the dependency version numbers in the cloud-haskell meta package + +Now you'll want to go and update the change log and release notes for each +project. Change logs are stored in the individual project's git repository, +whilst release notes are stored on the wiki. This is easy to forget, as I +discovered! Change logs should be more concise than full blown release +notes. + +Generate the packages with `cabal sdist` and test them all locally, then +upload them to hackage. Don't forget to upload the cloud-haskell meta-package +too! + +#### After the release + +**Now** you should tag all the projects with the relevant version number. +Since moving to individual git repositories, the tagging scheme is now +`x.y.z` and *not* `-x.y.z`. Once you've tagged the release, create +a branch named `release-x.y.z` and push both the newly created tag(s) and the +branch(es). + +Once the release is out, you should go to [github](https://github.com/haskell-distributed) +and close all the tickets for the release. + +After that, it's time to tweet about the release, post to the parallel-haskell +mailing list, blog etc. Spread the word. + +[1]: https://github.com/haskell-distributed +[2]: https://github.com/haskell-distributed/haskell-distributed.github.com +[3]: http://hackage.haskell.org +[4]: http://git-scm.com/book/en/Git-Basics-Tagging +[5]: https://groups.google.com/forum/?fromgroups=#!forum/parallel-haskell +[6]: https://groups.google.com/forum/?fromgroups#!forum/cloud-haskell-developers +[7]: https://travis-ci.org/ diff --git a/website/wiki/networktransport.md b/website/wiki/networktransport.md new file mode 100644 index 00000000..f6fb51a4 --- /dev/null +++ b/website/wiki/networktransport.md @@ -0,0 +1,396 @@ +--- +layout: wiki +title: Network.Transport +wiki: Overview +--- + +### Overview + +`Network.Transport` is a Network Abstraction Layer which provides +the following high-level concepts: + +* Nodes in the network are represented by `EndPoint`s. These are heavyweight stateful objects. +* Each `EndPoint` has an `EndPointAddress`. +* Connections can be established from one `EndPoint` to another using the `EndPointAddress` of the remote end. +* The `EndPointAddress` can be serialised and sent over the network, where as `EndPoint`s and connections cannot. +* Connections between `EndPoint`s are unidirectional and lightweight. +* Outgoing messages are sent via a `Connection` object that represents the sending end of the connection. +* Incoming messages for **all** of the incoming connections on an `EndPoint` are collected via a shared receive queue. +* In addition to incoming messages, `EndPoint`s are notified of other `Event`s such as new connections or broken connections. + +This design was heavily influenced by the design of the [Common Communication Interface/CCI][1]. +Important design goals are: + +* Connections should be lightweight: it should be no problem to create thousands of connections between endpoints. +* Error handling is explicit: every function declares as part of its type which errors it can return (no exceptions are thrown) +* Error handling is "abstract": errors that originate from implementation specific problems (such as "no more sockets" in the TCP implementation) get mapped to generic errors ("insufficient resources") at the Transport level. + +It is intended that `Network.Transport` can be instantiated to use +many different protocols for message passing: TCP/IP, UDP, MPI, CCI, +ZeroMQ, ssh, MVars, Unix pipes and more. Currently, we offer a TCP/IP +transport and (mostly for demonstration purposes) an in-memory +`Chan`-based transport. + +### **Package status** + +The TCP/IP implementation of Network.Transport should be usable, if not +completely stable yet. The design of the transport layer may also still change. +Feedback and suggestions are most welcome. Email [Duncan](mailto:duncan@well-typed.com) or [Edsko](mailto:edsko@well-typed.com) at Well-Typed, find us at #haskell-distributed on +Freenode, or post on the [Parallel Haskell][2] mailing list. + +You may also submit issues on [github][8]. + +### Hello World + +For a flavour of what programming with `Network.Transport` looks like, here is a tiny self-contained example. + +{% highlight haskell %} +import Network.Transport +import Network.Transport.TCP (createTransport, defaultTCPParameters) +import Control.Concurrent +import Control.Monad +import Data.String + +main :: IO () +main = do + serverAddr <- newEmptyMVar + clientDone <- newEmptyMVar + serverDone <- newEmptyMVar + + Right transport <- createTransport "127.0.0.1" "10080" defaultTCPParameters + + -- "Server" + forkIO $ do + Right endpoint <- newEndPoint transport + putMVar serverAddr (address endpoint) + + forever $ do + event <- receive endpoint + case event of + Received _ msg -> print msg + ConnectionClosed{} -> putMVar serverDone () + _ -> return () -- ignore + + + -- "Client" + forkIO $ do + Right endpoint <- newEndPoint transport + Right conn <- do addr <- readMVar serverAddr + connect endpoint addr ReliableOrdered defaultConnectHints + send conn [fromString "Hello world"] + putMVar clientDone conn + + -- Wait for the client to finish + conn <- takeMVar clientDone + close conn + takeMVar serverDone +{% endhighlight %} + +We create a "server" and a "client" (each represented by an `EndPoint`). +The server waits for `Event`s and whenever it receives a message it just prints +it to the console; it ignores all other messages. The client sets up a connection +to the server, sends a single message, and then signals to the main process +that it is done. + +### More Information + +* [Programming with Network.Transport][4] introduces `Network.Transport` from an application developer's point of view. +* [Creating New Transports][5] describes how to design new instantiations of `Network.Transport` for other messaging protocols, and describes the TCP transport in some detail as a guiding example. +* [New backend and transport design][6] has some notes about the design of the transport layer. Note however that this page is currently out of date. + +### How can I help? + +If you want to help with the development of `Network.Transport`, you can help in one of two ways: + +1. Play with the TCP implementation. Do the tutorial [Programming with Network.Transport][4]. Write some simple applications. Make it break and report the bugs. +2. If you have domain specific knowledge of other protocols (UDP, MPI, CCI, ZeroMQ, ssh, sctp, RUDP, enet, UDT, etc.) and you think it would be useful to have a Transport implementation for that protocol, then implement it! [Creating New Transports][5] might be a good place to start. Not only would it be great to have lots of supported protocols, but the implementation of other protocols is also a good test to see if the abstract interface that we provide in `Network.Transport` is missing anything. + +Note however that the goal of `Network.Transport` is _not_ to provide a general purpose network abstraction layer, but rather it is designed to support certain kinds of applications. [New backend and transport design][6] contains some notes about this, although it is sadly out of date and describes an older version of the API. + +If you are interested in helping out, please add a brief paragraph to +[Applications and Other Protocols][7] so that we can coordinate the efforts. + +-------- + +### The TCP Transport + +#### Overview + +When a TCP transport is created a new server is started which listens on a +given port number on the local host. In order to support multiple connections +the transport maintains a set of channels, one per connection, represented as a +pair of a `MVar [ByteString]` and a list of pairs `(ThreadId, Socket)` of +threads that are listening on this channel. A source end then corresponds to a +hostname (the hostname used by clients to identity the local host), port +number, and channel ID; a receive end simply corresponds to a channel ID. + +When `mkTransport` creates a new transport it spawns a thread that listens for +incoming connections, running `procConnections` (see below). The set of +channels (connections) associated with the transport is initialized to be +empty. + +`newConnectionWith` creates a new channel and add its to the transport channel +map (with an empty list of associated threads). + +To serialize the source end we encode the triple of the local host name, port +number, and channel ID, and to deserialize we just decode the same triple +(deserialize does not need any other properties of the TCP transport). + +To connect to the source end we create a new socket, connect to the server at +the IP address specified in the TCPConfig, and send the channel number over the +connection. Then to `closeSourceEnd` we simply close the socket, and to send a +bunch of byte strings we output them on the socket. + +To receive from the target end we just read from the channel associated with +the target end. To `closeTargetEnd` we find kill all threads associated with +the channel and close their sockets. + +When somebody connects to server (running `procConnections`), he first sends a +channel ID. `procConnections` then spawns a new thread running +`procMessages` which listens for bytestrings on the socket and output them on +the specified channel. The ID of this new thread (and the socket it uses) are +added to the channel map of the transport. + +`closeTransport` kills the server thread and all threads that were listening on +the channels associated with the transport, and closes all associated sockets. + +#### Improving Latency + +A series of benchmarks has shown that + +* The use of `-threaded` triples the latency. + +* Prepending a header to messages has a negligible effect on latency, even when + sending very small packets. However, the way that we turn the length from an + `Int32` to a `ByteString` _does_ have a significant impact; in particular, + using `Data.Serialize` is very slow (and using Blaze.ByteString not much + better). This is fast: + +{% highlight haskell %} +foreign import ccall unsafe "htonl" htonl :: CInt -> CInt + +encodeLength :: Int32 -> IO ByteString +encodeLength i32 = + BSI.create 4 $ \p -> + pokeByteOff p 0 (htonl (fromIntegral i32)) +{% endhighlight %} + +* We do not need to use `blaze-builder` or related; + `Network.Socket.Bytestring.sendMany` uses vectored I/O. On the client side + doing a single `recv` to try and read the message header and message, rather + one to read the header and one to read the payload improves latency, but only + by a tiny amount. + +* Indirection through an `MVar` or a `Chan` does not have an observable effect + on latency. + +* When two nodes _A_ and _B_ communicate, latency is worse when they + communicate over two pairs of sockets (used unidirectionally) rather than one + pair (used bidirectionally) by about 20%. This is not improved by using + `TCP_NODELAY`, and might be because [acknowledgements cannot piggyback with + payload][9] this way. It might thus be worthwhile to try and reuse TCP + connections (or use UDP). + +---- + +### Adding Support for Multicast to the Transport API + +Here we describe various design options for adding support for multicast +to the Transport API. + +#### Creating a new multicast group + +We can either have this as part of the transport + +{% highlight haskell %} + data Transport = Transport { + ... + , newMulticastGroup :: IO (Either Error MulticastGroup) + } + + data MulticastGroup = MulticastGroup { + ... + , multicastAddress :: MulticastAddress + , deleteMulticastGroup :: IO () + } +{% endhighlight %} + +or as part of an endpoint: + +{% highlight haskell %} + data Transport = Transport { + newEndPoint :: IO (Either Error EndPoint) + } + + data EndPoint = EndPoint { + ... + , newMulticastGroup :: IO (Either Error MulticastGroup) + } +{% endhighlight %} + +It should probably be part of the `Transport`, as there is no real connection +between an endpoint and the creation of the multigroup (however, see section +"Sending messages to a multicast group"). + +#### Subscribing to a multicast group + +This should be part of an endpoint; subscribing basically means that the +endpoint wants to receive events when multicast messages are sent. + +We could reify a subscription: + +{% highlight haskell %} + data EndPoint = EndPoint { + ... + , multicastSubscribe :: MulticastAddress -> IO MulticastSubscription + } + + data MulticastSubscription = MulticastSubscription { + ... + , multicastSubscriptionClose :: IO () + } +{% endhighlight %} + +but this suggests that one might have multiple subscriptions to the same group +which can be distinguished, which is misleading. Probably better to have: + +{% highlight haskell %} + data EndPoint = EndPoint { + multicastSubscribe :: MulticastAddress -> IO () + , multicastUnsubscribe :: MulticastAddress -> IO () + } +{% endhighlight %} + +#### Sending messages to a multicast group + +An important feature of the Transport API is that we are clear about which +operations are *lightweight* and which are not. For instance, creating new +endpoints is not lightweight, but opening new connections to endpoints is (as +light-weight as possible). + +Clearly the creation of a new multicast group is a heavyweight operation. It is +less evident however if we can support multiple lightweight "connections" to the +same multicast group, and if so, whether it is useful. + +If we decide that multiple lightweight connections to the multigroup is useful, +one option might be + +{% highlight haskell %} + data EndPoint = EndPoint { + ... + , connect :: Address -> Reliability -> IO (Either Error Connection) + , multicastConnect :: MulticastAddress -> IO (Either Error Connection) + } + + data Connection = Connection { + connectionId :: ConnectionId + , send :: [ByteString] -> IO () + , close :: IO () + , maxMsgSize :: Maybe Int + } + + data Event = + Receive ConnectionId [ByteString] + | ConnectionClosed ConnectionId + | ConnectionOpened ConnectionId ConnectionType Reliability Address +{% endhighlight %} + +The advantage of this approach is it's consistency with the rest of the +interface. The problem is that with multicast we cannot reliably send any +control messages, so we cannot make sure that the subscribers of the multicast +group will receive ConnectionOpened events when an endpoint creates a new +connection. Since we don't support these "connectionless connections" anywhere +else in the API this seems inconsistent with the rest of the design (this +implies that an "unreliable" Transport over UDP still needs to have reliable +control messages). (On the other hand, if we were going to support reliable +multicast protocols, then that would fit this design). + +If we don't want to support multiple lightweight connections to a multicast +group then a better design would be + +{% highlight haskell %} + data EndPoint = EndPoint { + , connect :: Address -> Reliability -> IO (Either Error Connection) + , multicastSend :: MulticastAddress -> [ByteString] -> IO () + } + + data Event = + ... + | MulticastReceive Address [ByteString] +{% endhighlight %} + +or alternatively + +{% highlight haskell %} + data EndPoint = EndPoint { + ... + , resolveMulticastGroup :: MulticastAddress -> IO (Either Error MulticastGroup) + } + + data MulticastGroup = MulticastGroup { + , ... + , send :: [ByteString] -> IO () + } +{% endhighlight %} + +If we do this however we need to make sure that newGroup is part an `EndPoint`, +not the `Transport`, otherwise `send` will not know the source of the message. +The version with `resolveMulticastGroup` has the additional benefit that in +"real" implementations we will probably need to allocate some resources before +we can send to the multicast group, and need to deallocate these resources at +some point too. + +### The current solution + +The above considerations lead to the following tentative proposal: + +{% highlight haskell %} + data Transport = Transport { + newEndPoint :: IO (Either Error EndPoint) + } + + data EndPoint = EndPoint { + receive :: IO Event + , address :: Address + , connect :: Address -> Reliability -> IO (Either Error Connection) + , newMulticastGroup :: IO (Either Error MulticastGroup) + , resolveMulticastGroup :: MulticastAddress -> IO (Either Error MulticastGroup) + } + + data Connection = Connection { + send :: [ByteString] -> IO () + , close :: IO () + } + + data Event = + Receive ConnectionId [ByteString] + | ConnectionClosed ConnectionId + | ConnectionOpened ConnectionId Reliability Address + | MulticastReceive MulticastAddress [ByteString] + + data MulticastGroup = MulticastGroup { + multicastAddress :: MulticastAddress + , deleteMulticastGroup :: IO () + , maxMsgSize :: Maybe Int + , multicastSend :: [ByteString] -> IO () + , multicastSubscribe :: IO () + , multicastUnsubscribe :: IO () + , multicastClose :: IO () + } +{% endhighlight %} + +where `multicastClose` indicates to the runtime that this endpoint no longer +wishes to send to this multicast group, and we can therefore deallocate the +resources we needed to send to the group (these resources can be allocated on +`resolveMulticastGroup` or on the first `multicastSend`; the advantage of the +latter is that is somebody resolves a group only to subscribe to it, not to +send to it, we don't allocate any unneeded resources). + +[1]: http://www.olcf.ornl.gov/center-projects/common-communication-interface/ +[2]: https://groups.google.com/forum/?fromgroups#!forum/parallel-haskell +[4]: /tutorials/tutorial-NT2.html +[5]: /wiki/newtransports.html +[6]: /wiki/newdesign.html +[7]: /wiki/protocols.html +[8]: https://github.com/haskell-distributed +[9]: http://lists.freebsd.org/pipermail/freebsd-hackers/2009-March/028006.html "2 uni-directional TCP connection good?" diff --git a/website/wiki/newdesign.md b/website/wiki/newdesign.md new file mode 100644 index 00000000..5cd14089 --- /dev/null +++ b/website/wiki/newdesign.md @@ -0,0 +1,583 @@ +--- +layout: wiki +title: New Backend and Transport Design +wiki: Outline +--- + +Outline +======= + +This is a outline of the problem and a design for a new `distributed-process` (Cloud Haskell) implementation. + +Compared to the initial implementation, the aim is not to change the main API but to give more flexibility in the network layer, both in the transport technology: + + * shared memory, + * IP, + * HPC interconnects + +and in configuration: + + * neighbour discovery/startup + * network parameter tuning + +The approach we take is to abstract over a network transport layer. That is, we define an interface between the upper layers of the distributed-process library (the `Process` monad and all that) and the network transport layer. We keep the interface to the upper layers essentially the same but are able to switch the transport layer. + +### Use cases + + * networking for the `distributed-process` package + * networked versions of DPH + * other distributed/cluster programming use cases + +Non-use cases: + + * general client/server networking + * general internet services + +In addition to `distributed-process`, it is hoped that an independent transport layer will be useful for other middleware and applications. It is not the intention however to be compatible and interoperable with existing protocols like HTTP. This transport system is for use cases where you control all the nodes involved. It is not intended for use cases where you need to interoperate with other independent components. + +An good comparison is Erlang and use cases where people choose Erlang's native VM-to-VM network protocol rather than picking a standard protocol like HTTP. + +---- + +### Network transports + +There are "transports" that focus purely on transporting data. Examples are: + + * TCP/IP, UDP + * InfiniBand/Verbs (or one of their other 10 protocols or so) + * pipes (Unix/Win32) + * NUMA transports (shared memory) + * PCI transports + * Portals + * CCI + +The last two (Portals and CCI) are libraries that attempt to provide consistent semantics over multiple lower protocols. CCI appears particularly promising. + +Then there are transports embedded in generally much larger libraries, and +layered on one or more of the above. Examples are: + + * MPI + * ZeroMQ + * ssh + * SSL sockets + * HTTP connections + * RPC connections (many flavours) + +Generally this second group of transports have the following attributes: + +* The semantics are richer. +* There is a bigger overhead (especially noticeable for low-latency HPC + transports, less so for IP transports) +* There are large libraries of functionality available. Unless re-writing + those libraries from scratch is desirable, it's nice to have access to + all of it. +* The failure semantics are very different from that of the underlying low + level transport. + +Experience indicates that it is difficult to use a "fat" protocol in place of a thin one merely for the purpose of moving packets (due to the different semantics, and particularly failure semantics). If you use a fat one, you typically want to be using the richer semantics and/or library of additional routines. + +### Terminology: Addresses and Endpoints + +An address is a resource name. This is a value and has value semantics. In particular it can be serialised and deserialised. + +An endpoint is a networking level object. That is, it is a stateful object with identity and it has reference semantics. + +### Approach + +We want to provide a common interface to multiple different transports. We only intend to provide relatively limited functionality for sending messages between nodes in a network. We are primarily targeting lower level transports like IP not the higher level transports with richer semantics like HTTP. + +We want enough to allow code to be written against the interface to actually be reusable with multiple transports. We want to be able to take full advantage of the configuration/tuning parameters for each underlying transport so that we can maximise performance. These intentions tend to pull in opposite directions. + +To give us some leeway, we do not require that our common interface covers all the functionality of each of the underlying transports. We are happy to divide functionality between a common interface and interfaces specific to each transport backend. We do however want to maximise the functionality covered by the common interface so that we can maximise the amount of code that can be reusable between multiple transports. + +Looking at different transports, the area where they differ the most is in initialisation and initial configuration, addresses and per-connection performance parameters. Our approach to partitioning into common and per-backend interfaces is to put configuration, initialisation, initial neighbour creation/discovery and initial connection establishment into per-backend interfaces and to put everything else into the common interface. This enables us to write reusable code that works on the assumption that we already have connections to our neighbour nodes. From there we can create extra connections and send messages. + +A particular challenge is the per-connection performance parameters. It is vital for performance to be able to set these, but they differ significantly between transports. Our proposed solution to this is described below in the detailed design. + +---- + +### System outline + +The following diagram shows dependencies between the various modules for the initial Cloud Haskell implementation. Arrows represent explicit module dependencies. + +---- + + +------------------------------+ + | Application | + +------------------------------+ + | + V + +------------------------------+ + | Cloud Haskell | + +------------------------------+ + | + V + +------------------------------+ + | Haskell network (IP) library | + +------------------------------+ + +---- + +As the diagram indicates, the initial implementation is monolithic and uses a single specific transport (TCP/IP). + +The next diagram shows the various modules that are envisaged in the new design. We partition the system into the Cloud Haskell layer and a separate network transport layer. Each of the two layers has backend packages for different transports. + +---- + + +------------------------------------------------------------+ + | Application | + +------------------------------------------------------------+ + | | + V V + +-------------------------+ +------------------------------+ + | Cloud Haskell |<--| Cloud Haskell Backend | + | (distributed-process) | | (distributed-process-...) | + +-------------------------+ +------------------------------+ + | ______/ | + V V V + +-------------------------+ +------------------------------+ + | Transport Interface |<--| Transport Implementation | + | (network-transport) | | (network-transport-...) | + +-------------------------+ +------------------------------+ + | + V + +------------------------------+ + | Haskell/C Transport Library | + +------------------------------+ + +---- + +We still expect applications to use the the Cloud Haskell layer directly. Additionally the application also depends on a specific Cloud Haskell backend, which provides functions to allow the initialisation of the transport layer using whatever topology might be appropriate to the application. + +Complete applications will necessarily depend on a specific Cloud Haskell backend and would require (hopefully minor) code changes to switch backend. However libraries of reusable distributed algorithms could be written that depend only on the Cloud Haskell package. + +Both the Cloud Haskell interface and implementation make use of the transport interface. This also serves as an interface for the transport implementations, which may for example, be based on some external library written in Haskell or C. + +Typically a Cloud Haskell backend will depend on a single transport implementation. There may be several different Cloud Haskell backends that all make use of the same transport implementation but that differ in how they discover or create peers. For example one backend might be designed for discovering peers on a LAN by broadcasting, while another might create peers by firing up new VMs using some cloud system such as EC2. Both such backends could still use the same TCP transport implementation. + +This example also illustrates somewhat the distinction between a transport implementation and a Cloud Haskell backend. The transport implementation is that one deals with the low level details of the network transport while the other makes use of a transport implementation to initialise a Cloud Haskell node. Part of the reason for the separation is that the network layer is intended to be reusable on its own without having to use the Cloud Haskell layer. + + +### Model overview + +We will now focus on the transport layer. + +Before describing the interfaces in detail we will give an overview of the networking model that our interfaces use. In particular we will focus on the common part of the interface rather than the per-backend parts. + +Compared to traditional networking interfaces, like the venerable socket API, our model is a little different looking. The socket API has functionality for creating listening sockets and trying to establish connections to foreign addresses (which may or may not exist). + +By contrast, our model is much more like a set of Unix processes connected via anonymous unix domain sockets (which are much like ordinary unix pipes). In particular, unix domain sockets can be created anonymously with two ends (see socketpair(2)) and either end may be passed between processes over existing sockets. Note that this arrangement only allows communication via existing connections: new sockets can be made and can be passed around, but only to processes that are already part of the network graph. It does not provide any method for making connections to processes not already connected into the network graph. + +This anonymous unix domain socket model has the advantage of simplicity. There is no need for addresses: socket endpoints are simply created anonymously and passed between processes. Obviously this simplicity comes at the cost of not actually being able to establish new networks from scratch -- only to make new connections within existing networks. By putting the establishment of initial connections outside the common interface, we allow that aspect to be different for each network transport and network topology. We can write distributed algorithms that are reusable with multiple transports, on the assumption that the network peers are already known. + +We hope this is a reasonable compromise, otherwise it is hard to include connection creation in the common interface since each transport has its own address spaces and parameters for new connections. + +Our model is almost as simple as the anonymous unix domain socket model. We have to make it work with real networks, without the assistance of a shared OS. Unlike with unix domain sockets where both ends can be moved (and indeed shared) between processes, we differentiate the source and target endpoints and only allow the source endpoint to be moved around. Additionally, because we cannot actually move a stateful object like a source endpoint from one node to another, we re-introduce the notion of an address. However it is a severely limited notion of address: we cannot make new addresses within the common interface, only take the address of existing target endpoints. Those addresses can then be sent by value over existing links and used to create source endpoints. Thus every address created in this way uniquely identifies a target endpoint. + +This model gives us something like many-to-one connections. The target endpoint cannot be "moved". The source endpoint can be "copied" and all copies can be used to send messages to the target endpoint. + + +### Connection kinds and behaviours + +The above overview covers our primary kind of connection. Overall we provide four kinds of connection. + + 1. many-to-one, reliable ordered delivery of arbitrary sized messages + 2. many-to-one, reliable unordered delivery of arbitrary sized messages + 3. many-to-one, unreliable delivery of messages with bounded size + 4. multicast one-to-many, unreliable delivery of messages with bounded size + +The first one is the primary kind of connection, used in most circumstances while the other three are useful in more specialised cases. The first three are all ordinary point-to-point connections with varying degrees of reliability and ordering guarantee. We provide only datagram/message style connections, not stream style. + +For our primary kind of connection, we stipulate that it provides reliable ordered delivery of arbitrary sized messages. More specifically: + + * Message/datagram (rather than stream oriented) + * Arbitrary message size + * Non-corruption, that is messages are delivered without modification and are + delivered whole or not at all. + * Messages are delivered at most once + * Messages are delivered in-order. Subsequent messages are not delivered + until earlier ones are delivered. This only applies between messages sent + between the same pair of source and target endpoints -- there is no + ordering between messages sent from different source endpoints to the same + target endpoint. + * Somewhat-asynchronous send is permitted: + * send is not synchronous, send completing does not imply successful + delivery + * send side buffering is permitted but not required + * receive side buffering is permitted but not required + * send may block (e.g. if too much data is in flight or destination buffers + are full) + * Mismatched send/receive is permitted. + It is not an error to send without a thread at the other end already + waiting in receive (but it may block). + +These properties are based on what we can get with (or build on top of) tcp/ip, udp/ip, unix IPC, MPI and the CCI HPC transport. (In particular CCI emphasises the property that a node should be able to operate with receive buffer size that is independent of the number of connections/nodes it communicates with unlike tcp/ip which has a buffer per connection. Also, CCI allows unexpected receipt of small messages but requires pre-arrangement for large transfers so the receive side can prepare buffers). + +For the reliable unordered connections the ordering requirement is dropped while all others are preserved. + +For the unreliable connections (both point to point and multicast) the ordering, at-most-once and arbitrary message size requirements are dropped. All others are preserved. For these unreliable connections there may be an upper limit on message length and there is a way to discover that limit on a per-connection basis for established connections. + +While transport implementations must guarantee the provision of the reliable ordered connection kind (and the unordered and unreliable variants can obviously be emulated at no extra cost in terms of the reliable ordered kind), transport implementations do not need to guarantee the provision of multicast connections. In many transports, including IP, the availability of multicast connections cannot be relied upon. Transport clients have to be prepared for the creation of multicast connections to fail. Since this is the case even for transports that can support multicast, we use the same mechanism for transports that have no multicast support at all. + + +### Blocking vs. non-blocking send and receive + +For sending or receiving messages, one important design decision is how it interacts with Haskell lightweight threads. Almost all implementations are going to consist of a Haskell-thread blocking layer built on top of a non-blocking layer. We could choose to put the transport interface at the blocking or non-blocking layer. We have decided to go for a design that is blocking at the Haskell thread level. This makes the backend responsible for mapping blocking calls into something non-blocking at the OS thread level. That is, the backend must ensure that a blocking send/receive only blocks the Haskell thread, not all threads on that core. In the general situation we anticipate having many Haskell threads blocked on network IO while other Haskell threads continue doing computation. (In an IP backend we get this property for free because the existing network library implements the blocking behaviour using the IO manager.) + + +### Transport common interface + +We start with a Transport. Creating a Transport is totally backend dependent. More on that later. + +A Transport lets us create new connections. Our current implementation provides ordinary reliable many-to-one connections, plus the multicast one-to-many connections. It does not yet provide unordered or unreliable many-to-one connections, but these will closely follow the interface for the ordinary reliable many-to-one connections. + +{% highlight haskell %} +data Transport = Transport + { newConnectionWith :: Hints -> IO TargetEnd + , newMulticastWith :: Hints -> IO MulticastSourceEnd + , deserialize :: ByteString -> Maybe Address + } +{% endhighlight %} + +We will start with ordinary connections and look at multicast later. + +We will return later to the meaning of the hints. We have a helper function for the common case of default hints. + +{% highlight haskell %} +newConnection :: Transport -> IO TargetEnd +newConnection transport = newConnectionWith transport defaultHints +{% endhighlight %} + +The `newConnection` action creates a new connection and gives us its `TargetEnd`. The `TargetEnd` is a stateful object representing one endpoint of the connection. For the corresponding source side, instead of creating a stateful `SourceEnd` endpoint, we can take the address of any `TargetEnd`: + +{% highlight haskell %} +address :: TargetEnd -> Address +{% endhighlight %} + +The reason for getting the address of the target rather than `newConnection` just giving us a `SourceEnd` is that usually we only want to create a `SourceEnd` on remote nodes not on the local node. + +An `Address` represents an address of an existing endpoint. It can be serialised and copied to other nodes. On the remote node the Transport's `deserialize` function is is used to reconstruct the `Address` value. Once on the remote node, a `SourceEnd` can created that points to the `TargetEnd` identified by the `Address`. + +{% highlight haskell %} +data Address = Address + { connectWith :: SourceHints -> IO SourceEnd + , serialize :: ByteString + } +{% endhighlight %} + +Again, ignore the hints for now. + +{% highlight haskell %} +connect :: Address -> IO SourceEnd +connect address = connectWith address defaultSourceHints +{% endhighlight %} + +The `connect` action makes a stateful endpoint from the address. It is what really establishes a connection. After that the `SourceEnd` can be used to send messages which will be received at the `TargetEnd`. + +The `SourceEnd` and `TargetEnd` are then relatively straightforward. They are both stateful endpoint objects representing corresponding ends of an established connection. + +{% highlight haskell %} +newtype SourceEnd = SourceEnd + { send :: [ByteString] -> IO () + } + +newtype TargetEnd = TargetEnd + { receive :: IO [ByteString] + , address :: Address + } +{% endhighlight %} + +The `SourceEnd` sports a vectored send. That is, it allows sending a message stored in a discontiguous buffer (represented as a list of ByteString chunks). The `TargetEnd` has a vectored receive, though it is not vectored in the traditional way because it is the transport not the caller that handles the buffers and decides if it will receive the incoming message into a single contiguous buffer or a discontiguous buffer. Callers must always be prepared to handle discontiguous incoming messages or pay the cost of copying into a contiguous buffer. + +The use of discontiguous buffers has performance advantages and with modern binary serialisation/deserialisation libraries their use is not problematic. + +TODO: we have not yet covered closing connections, shutting down the transport and failure modes / exceptions. + + +### Unordered and unreliable connections + +Though not currently implemented, these connection types follow the same pattern as the normal reliable ordered connection. The difference is just one of behaviour. The only difference is that the source end for unreliable connections lets one find out the maximum message length (i.e. the MTU). + +The reason each of these are separate types is because they have different semantics and must not be accidentally confused. The reason we don't use a parameterised type is because typically the implementations will be different so this simplifies the implementation. + +### Multicast connections + +For the multicast connections, the address, source and target ends are analogous. The difference is that the address that is passed around is used to create a target endpoint so that multiple nodes can receive the messages sent from the source endpoint. It's sort of the dual of the ordinary many-to-one connections. + +The `newMulticast` is the other way round compared to `newConnection`: it gives us a stateful `MulticastSourceEnd` from which we can obtain the address `MulticastAddress`. + +{% highlight haskell %} +newMulticast :: Transport -> IO MulticastSourceEnd +newMulticast transport = newMulticastWith transport defaultHints + +newtype MulticastSourceEnd = MulticastSourceEnd + { multicastSend :: [ByteString] -> IO () + , multicastAddress :: MulticastAddress + , multicastMaxMsgSize :: Int + } + +newtype MulticastAddress = MulticastAddress + { multicastConnect :: IO MulticastTargetEnd + } + +newtype MulticastTargetEnd = MulticastTargetEnd + { multicastReceive :: IO [ByteString] + } +{% endhighlight %} + +The multicast send has an implementation-defined upper bound on the message size which can be discovered on a per-connection basis. + + +### Creating a Transport via a transport backend + +Creating a `Transport` object is completely backend-dependent. There is the opportunity to pass in a great deal of configuration data at this stage and to use types specific to the backend to do so (e.g. TCP parameters). + +In the simplest case (e.g. a dummy in-memory transport) there might be nothing to configure: + +{% highlight haskell %} +mkTransport :: IO Transport +{% endhighlight %} + +For a TCP backend we might have: + +{% highlight haskell %} +mkTransport :: TCPConfig -> IO Transport + +data TCPConfig = ... +{% endhighlight %} + +This `TCPConfig` can contain arbitrary amounts of configuration data. Exactly what it contains is closely connected with how we should set per-connection parameters. + + +### Connection parameters and hints + +As mentioned previously, a major design challenge with creating a common transport interface is how to set various parameters when creating new connections. Different transports have widely different parameters, for example the parameters for a TCP/IP socket have very little in common with a connection using shared memory or infiniband. Yet being able to set these parameters is vital for performance in some circumstances. + +The traditional sockets API handles this issue by allowing each different kind of socket to have its own set of configuration parameters. This is fine but it does not really enable reusable code. Generic, transport-independent code would need to get such parameters from somewhere, and if connections used for different purposes needed different parameters then the problem would be worse. + +With our design approach it is easy to pass backend-specific types and configuration parameters when a transport is initialised, but impossible to pass backend-specific types when creating connections later on. + +This makes it easy to use a constant set of configuration parameters for every connection. For example for our example TCP backend above we could have: + +{% highlight haskell %} +data TCPConfig = TCPConfig { + socketConfiguration :: SocketOptions + } +{% endhighlight %} + +This has the advantage that it gives us full access to all the options using the native types of the underlying network library (`SocketOptions` type comes from the `network` library). + +The drawback of this simple approach is that we cannot set different options for different connections. To optimise performance in some applications or networks we might want to use different options for different network addresses (e.g. local links vs longer distance links). Similarly we might want to use different options for connections that are used differently, e.g. using more memory or network resources for certain high bandwidth connections, or taking different tradeoffs on latency vs bandwidth due to different use characteristics. + +Allowing different connection options depending on the source and destination addresses is reasonably straightforward: + +{% highlight haskell %} +data TCPConfig = TCPConfig { + socketConfiguration :: Ip.Address -> Ip.Address + -> SocketOptions + } +{% endhighlight %} + +We simply make the configuration be a function that returns the connection options but is allowed to vary depending on the IP addresses involved. Separately this could make use of configuration data such as a table of known nodes, perhaps passed in by a cluster job scheduler. + +Having options vary depending on how the connection is to be used is more tricky. If we are to continue with this approach then it relies on the transport being able to identify how a client is using (or intends to use) each connection. Our proposed solution is that when each new connection is made, the client supplies a set of "hints". These are not backend specific, they are general indications of what the client wants, or how the client intends to use the connection. The backend can then interpret these hints and transform them into the real network-specific connection options: + +{% highlight haskell %} +data TCPConfig = TCPConfig { + socketConfiguration :: Hints -> Ip.Address -> Ip.Address + -> SocketOptions + } +{% endhighlight %} + +What exactly goes into the hints will have to be considered in consultation with networking experts and people implementing backends. In particular it might indicate if bandwidth or latency is more important (e.g. to help decide if NO_DELAY should be used), if the connection is to be heavily or lightly used (to help decide buffer size) etc. + +Using this approach may require a slightly different way of thinking about network programming and tuning than normal. Instead of specifying exactly what you want when creating each connection, you instead have to say how you intend to use the connection and then trust the backend to do the right thing. As noted however, the backend can take a custom configuration function that can pick very specific connection options, so long as it has enough information to distinguish the different classes of connections it is interested in. + +Middleware like Cloud Haskell faces this problem anyway. Because it is transport independent it cannot use network-specific connection options anyway, they would have to be passed in as configuration. The best that middleware can do is to provide what detail it can on how each connection is likely to be used (the information available to it is fairly limited). + +The only place where we are in a position to fully exploit all the network-specific connection options is when we have a complete (or near complete) application, using a specific transport, and we know what kind of network environment/hardware it will be used on. At this point, the ideal thing would indeed be to pass in a (perhaps complex) configuration when the application is launched, rather than modify the app and the middleware to pass down network-specific connection options to each place where connections are established. + +So hopefully if this model works, it might be quite nice in allowing the configuration to be more-or-less separated from the main program, allowing reusable code and still allowing turning to the network environment. + +A useful analogy perhaps is CSS. It allows medium-specific (screen, print, voice etc) configuration to be specified in detail but separately from the content/structure. It allows general/constant options to be specified easily but allows a fair degree of discrimination between different HTML elements and allows distinction based on class or id names. + +Following this analogy, it might prove useful in the most extreme cases to be able to give names/class/ids to connections in the hints, so that very detailed configurations could pick specific extra tweaks for specific connections or classes of connections. + + +### Cloud Haskell Usage + +Given the Transport interface described above, the main Cloud Haskell implementation then needs to be rebuilt on top, providing the same API as now, except for the initialisation and peer discovery. + +We were initially inclined to stipulate that the communication endpoints provided by our network transport be sufficiently lightweight that we could use one per cloud Haskell process (for each processes' input message queue) and one per cloud Haskell typed channel. The transport backend would then be responsible for doing any multiplexing necessary to give us lightweight endpoint resources. Unfortunately, when considering the design of the TCP/IP transport we could not find a sensible way to provide lightweight connection endpoints while at the same time avoiding "head of line" blocking and sensible buffering. + +We therefore assume for the moment that transport connections are heavyweight resources and the Cloud Haskell implementation will have to take care of multiplexing messages between lightweight processes over these connections. + +### Requirements for NodeID and ProcessId + +A `ProcessId` serves two purposes, one is to communicate with a process directly and the other is to talk about that process to various service processes. + +The main APIs involving a ProcessId are: + +{% highlight haskell %} +getSelfPid :: ProcessM ProcessId +send :: Serializable a => ProcessId -> a -> ProcessM () +spawn :: NodeId -> Closure (ProcessM ()) -> ProcessM ProcessId +{% endhighlight %} + +and linking and service requests: + +{% highlight haskell %} +linkProcess :: ProcessId -> ProcessM () +monitorProcess :: ProcessId -> ProcessId -> MonitorAction -> ProcessM () +nameQuery :: NodeId -> String -> ProcessM (Maybe ProcessId) +{% endhighlight %} + +A NodeId is used to enable us to talk to the service processes on a node. + +The main APIs involving a `NodeId` are: + +{% highlight haskell %} +getSelfNode :: ProcessM NodeId +spawn :: NodeId -> Closure (ProcessM ()) -> ProcessM ProcessId +nameQuery :: NodeId -> String -> ProcessM (Maybe ProcessId) +{% endhighlight %} + + +### NodeID and ProcessId representation + +So for a ProcessId we need: + + * a communication endpoint to the process message queue so we can talk to the + process itself + * the node id and an identifier for the process on that node so that we can + talk to node services about that process + +We define it as + +{% highlight haskell %} +data ProcessId = ProcessId SourceEnd NodeId LocalProcessId +{% endhighlight %} + +For a `NodeId` we need to be able to talk to the service processes on that node. + +{% highlight haskell %} +data NodeId = NodeId SourceEnd +{% endhighlight %} + +The single 'SourceEnd's is for talking to the basic service processes (ie the processes involved in implementing spawn and link/monitor). The service process Ids on each node are well known and need not be stored. + +### Cloud Haskell channel representation + +A cloud Haskell channel `SendPort` is similar to a `ProcessId` except that we do not need the `NodeId` because we do not need to talk about the process on the other end of the port. + +{% highlight haskell %} +data SendPort a = SendPort SourceEnd +{% endhighlight %} + +### Cloud Haskell backend initialisation and neighbour setup + +In the first implementation, the initialisation was done using: + +{% highlight haskell %} +remoteInit :: Maybe FilePath -> (String -> ProcessM ()) -> IO () +{% endhighlight %} + +This takes a configuration file (or uses an environment variable to find the same), an initial process, and it launches everything by reading the config, creating the local node and running the initial process. The initial process gets passed some role string obtained from the configuration file. + +One of the slightly tricky issues with writing a program for a cluster is how to initialise everything in the first place: how to get each node talking to the appropriate neighbours. + +The first cloud Haskell implementation provides: + +{% highlight haskell %} +type PeerInfo = Map String [NodeId] +getPeers :: ProcessM PeerInfo +findPeerByRole :: PeerInfo -> String -> [NodeId] +{% endhighlight %} + +The implementation obtains this information using magic and configuration files. + +Our new design moves this functionality out of the common interface entirely and into each Cloud Haskell backend. Consider for example the difference between neighbour setup in the following hypothetical Cloud Haskell backends: + + * A single-host multi-process model where we fork a number of OS processes (typically the number of CPU cores) and connect them by pipes. Here the neighbours are created at initialisation time and remain fixed thereafter. + * A cluster backend that uses a cluster job scheduler to start a binary on each node and inform each one of a certain number of their peers (e.g. forming some hypercube topology). + * A cloud backend that allows firing up VMs and starting new instances of the program on the new VMs. Here peers are not discovered but created, either at the start of the job or later to adjust for demand. + * A backend providing something like the current approach where nodes are discovered by broadcasting on the LAN. + +(As a side note: the latter three backends probably all use the same IP transport implementation, but they handle configuration and peer setup quite differently. The point being, there's more to a Cloud Haskell backend than a choice of transport implementation.) + +We think that making an interface that covers all these cases would be end up rather clumsy. We believe it is simpler to have each of these backends provide their own way to initialise and discover/create peer nodes. + +So in the new design, each application selects a Cloud Haskell backend by importing the backend and using an initialisation function from it. + +Exactly how this is exposed has not been finalised. Internally we have an abstraction `LocalNode` which is a context object that knows about all the locally running processes on the node. We have: + +{% highlight haskell %} +newLocalNode :: Transport -> IO LocalNode +runProcess :: LocalNode -> Process () -> IO () +{% endhighlight %} + +and each backend will (at least internally) have a function something like: + +{% highlight haskell %} +mkTransport :: {...config...} -> IO Transport +{% endhighlight %} + +So the initialisation process is more or less + +{% highlight haskell %} +init :: {...} -> Process () -> IO () +init config initialProcess = do + transport <- mkTransport config + localnode <- newLocalNode transport + runProcess localnode initialProcess +{% endhighlight %} + +We could export all these things and have applications plug them together. + +Alternatively we might have each backend provide an initialisation that does it all in one go. For example the backend that forks multiple OS process might have an init like this: + +{% highlight haskell %} +init :: Int -> ([NodeId] -> Process ()) -> IO () +{% endhighlight %} + +It takes a number of (OS) processes to fork and the initial (CH) process gets passes a corresponding number of remote `NodeId`s. + +For the backend that deals with VMs in the cloud, it might have two initialisation functions, one for the master controller node and one for slave nodes. + +{% highlight haskell %} +initMaster :: MasterConfig -> Process () -> IO () +initSlave :: SlaveConfig -> IO () +{% endhighlight %} + +Additionally it might have actions for firing up new VMs and running the program binary in slave mode on that VM: + +{% highlight haskell %} +spawnVM :: VmAccount -> IO VM +initOnVM :: VM -> IO NodeId +shutdownVM :: VM -> IO () +{% endhighlight %} + +For example, supposing in our application's 'main' we call the IP backend and initialise a Transport object, representing the transport backend for cloud Haskell: + +### Using multiple transports in the Cloud Haskell layer + +There are contexts where it makes sense to use more than one `Transport` in a single distributed application. The most common example is likely to be a local transport, e.g. shared memory or pipes, for communication between nodes that share the same host, and a second transport using a network (IP or some HPC network). This is a very common setup with OpenMPI for example which allows the use of multiple "byte transfer layers" (BTLs) which correspond roughly to our notion of transport. + +There are various challenges related to addressing. Assuming these can be solved, it should be considered how initialisation might be done when there are multiple transports / backends in use. We might want to have: + +{% highlight haskell %} +newLocalNode :: [Transport] -> IO LocalNode +{% endhighlight %} + +and expose it to the clients. + +Alternatively, instead of allowing arbitrary stacks of transports, we might make each backend pick a fixed combination of transports. This is likely to work OK because the range of sensible combinations is not very large. + + +### Open issues + + * Is the configuration model sufficient and if so, the exact details of what goes into the connection hints. See the section above about connection parameters and hints. + + * If connection endpoints should be lightweight or heavyweight. We think leaving it as heavyweight is the way to go, but perhaps others can see a plausible design. See the section on the Cloud Haskell implementation built on Transport interface. + + * What style of initialisation API should be exposed to Cloud Haskell clients, and how this should be divided between the common interface and the backend interfaces. See the section on Cloud Haskell backend initialisation and neighbour setup. diff --git a/website/wiki/newtransports.md b/website/wiki/newtransports.md new file mode 100644 index 00000000..69d614f5 --- /dev/null +++ b/website/wiki/newtransports.md @@ -0,0 +1,140 @@ +--- +layout: wiki +title: Building new Transports +wiki: Guide +--- + +## Guide + +On this page we describe the TCP Transport as an example for developers who wish to write their own instantiations of the Transport layer. The purpose of any such instantiation is to provide a function + +{% highlight haskell %} +createTransport :: -> IO (Either Transport) +{% endhighlight %} + +For instance, the TCP transport offers + +{% highlight haskell %} +createTransport :: N.HostName -> N.ServiceName -> IO (Either IOException Transport) +{% endhighlight %} + +This could be the only function that `Network.Transport.TCP` exports (the only reason it exports more is to provide an API for unit tests for the TCP transport, some of which work at a lower level). Your implementation will now be guided by the `Network.Transport` API. In particular, you will need to implement `newEndPoint`, which in turn will require you to implement `receive`, `connect`, etc. + +#### Mapping Network.Transport concepts to TCP + +The following picture is a schematic overview of how the Network.Transport concepts map down to their TCP counterparts. + +---- +![The TCP transport](/img/NetworkTCP.png) + +---- + +* The blue boxes represent `Transport` instances. At the top we have two Transport instances on the same TCP node 198.51.100.1. These could be as part of the same Haskell process or, perhaps more typically, in separate processes. Different Transport instances on the same host must get a different port number. +* The orange boxes represent `EndPoint`s. A Transport can have multiple EndPoints (or none). EndPointAddresses in the TCP transport are triplets `TCP host:TCP port:endpoint ID`. +* The heavyset lines represent (heavyweight, bidirectional) TCP connections; the squiggly lines represent Transport level (lightweight, unidirectional) connections. The TCP transport guarantees that at most a single TCP connection will be set up between any pair of endpoints; all lightweight connections get multiplexed over this single connection. +* All squiggly lines end up in a single fat dot in the middle of the endpoint. This represents a `Chan` on which all endpoint `Event`s are posted. + +## Implementation + +We briefly discuss the implementation of the most important functions in the Transport API. + +#### Setup (`createTransport`) + +When a TCP transport is created at host 192.51.100.1, port 1080, `createTransport` sets up a socket, binds it to 192.51.100.1:1080, and then spawns a thread to listen for incoming requests. This thread will handle the connection requests for all endpoints on this TCP node: individual endpoints do _not_ set up their own listening sockets. + +This is the only set up that `Network.Transport.TCP.createTransport` needs to do. + +#### Creating new endpoints (`newEndPoint`) + +In the TCP transport the set up of new endpoints is straightforward. We only need to create a new `Chan` on which we will output all the events and allocate a new ID for the endpoint. Now `receive` is just `readChan` and `address` is the triplet `host:port:ID` + +#### New connections (`connect`) + +Consider the situation shown in the diagram above, and suppose that endpoint 198.51.100.1:1081:0 (lets call it _A_) wants to connect to 198.51.100.2:1080:1 (_B_). Since there is no TCP connection between these two endpoints yet we must set one up. + +* _A_ creates a socket and connects to 198.51.100.2:1080. The transport thread at 198.51.100.2 accepts the connection. +* _A_ now sends two messages across the socket: first, the ID of the remote endpoint it wants to connect to (1) and then it own full address (192.51.100.1:1081:0). The first message is necessary because the remote transport is responsible for handling the connection requests for all its endpoints. The second message is necessary to ensure that when _B_ subsequently attempts to `connect` to _A_ we know that a TCP connection to _A_ is already available. +* _B_ will respond with `ConnectionRequestAccepted` and spawn a thread to listen for incoming messages on the newly created TCP connection. + +At this point there is a TCP connection between _A_ and _B_ but not yet a Network.Transport connection; at this point, however, the procedure is the same for all connection requests from _A_ to _B_ (as well as as from _B_ to _A_): + +* _A_ sends a `RequestConnectionId` message to _B_ across the existing TCP connection. +* _B_ creates a new connection ID and sends it back to _A_. At this point _B_ will output a `ConnectionOpened` on _B_'s endpoint. + +> A complication arises when _A_ and _B_ simultaneously attempt to connect each other and no TCP connection has yet been set up. In this case _two_ TCP connections will temporarily be created; _B_ will accept the connection request from _A_, keeping the first TCP connection, but _A_ will reply with `ConnectionRequestCrossed`, denying the connection request from _B_, and then close the socket. + +Note that connection IDs are _locally_ unique. When _A_ and _B_ both connect to _C_, then _C_ will receive two `ConnectionOpened` events with IDs (say) 1024 and 1025. However, when _A_ connects to _B_ and _C_, then it is entirely possible that the connection ID that _A_ receives from both _B_ and _C_ is identical. Connection IDs for outgoing connections are however not visible to application code. + +#### Sending messages (`send`) + +To send a message from _A_ to _B_ the payload is given a Transport header consisting of the message length and the connection ID. When _B_ receives the message it posts a `Received` event. + +#### Closing a connection + +To close a connection, _A_ just sends a `CloseConnection` request to _B_, and _B_ will post a `ConnectionClosed` event. + +When there are no more Transport connections between two endpoints the TCP connection between them is torn down. + +> Actually, it's not quite that simple, because _A_ and _B_ need to agree that the TCP connection is no longer required. _A_ might think that the connection can be torn down, but there might be a `RequestConnectionId` message from _B_ to _A_ in transit in the network. _A_ and _B_ both do reference counting on the TCP connection. When _A_'s reference count for its connection to _B_ reaches zero it will send a `CloseSocket` request to _B_. When _B_ receives it, and its refcount for its connection to _A_ is also zero, it will close its socket and reply with a reciprocal `CloseSocket` to _A_. If however _B_ had already sent a `RequestConnectionId` to _A_ it will simply ignore the `CloseSocket` request, and when _A_ receives the `RequestConnectionId` it simply forgets it ever sent the `CloseSocket` request. + +#### Transport instances for connectionless protocols + +In the TCP transport `createTransport` needs to do some setup, `newEndPoint` barely needs to do any at all, and `connect` needs to set up a TCP connection when none yet exists to the destination endpoint. In Transport instances for connectionless protocols this balance of work will be different. For instance, for a UDP transport `createTransport` may barely need to do any setup, `newEndPoint` may set up a UDP socket for the endpoint, and `connect` may only have to setup some internal datastructures and send a UDP message. + +#### Error handling + +Network.Transport API functions should not throw any exceptions, but declare explicitly in their types what errors can be returned. This means that we are very explicit about which errors can occur, and moreover map Transport-specific errors ("socket unavailable") to generic Transport errors ("insufficient resources"). A typical example is `connect` with type: + +{% highlight haskell %} +connect :: EndPoint -- ^ Local endpoint + -> EndPointAddress -- ^ Remote endpoint + -> Reliability -- ^ Desired reliability of the connection + -> IO (Either (TransportError ConnectErrorCode) Connection) +{% endhighlight %} + +`TransportError` is defined as + +{% highlight haskell %} +data TransportError error = TransportError error String + deriving Typeable +{% endhighlight %} + +and has `Show` and `Exception` instances so that application code has the option of `throw`ing returned errors. Here is a typical example of error handling in the TCP transport; it is an internal function that does the initial part of the TCP connection setup: create a new socket, and the remote endpoint ID we're interested in and our own address, and then wait for and return the response: + +{% highlight haskell %} +socketToEndPoint :: EndPointAddress -- ^ Our address + -> EndPointAddress -- ^ Their address + -> IO (Either (TransportError ConnectErrorCode) (N.Socket, ConnectionRequestResponse)) +socketToEndPoint (EndPointAddress ourAddress) theirAddress = try $ do + (host, port, theirEndPointId) <- case decodeEndPointAddress theirAddress of + Nothing -> throw (failed . userError $ "Could not parse") + Just dec -> return dec + addr:_ <- mapExceptionIO invalidAddress $ N.getAddrInfo Nothing (Just host) (Just port) + bracketOnError (createSocket addr) N.sClose $ \sock -> do + mapExceptionIO failed $ N.setSocketOption sock N.ReuseAddr 1 + mapExceptionIO invalidAddress $ N.connect sock (N.addrAddress addr) + response <- mapExceptionIO failed $ do + sendMany sock (encodeInt32 theirEndPointId : prependLength [ourAddress]) + recvInt32 sock + case tryToEnum response of + Nothing -> throw (failed . userError $ "Unexpected response") + Just r -> return (sock, r) + where + createSocket :: N.AddrInfo -> IO N.Socket + createSocket addr = mapExceptionIO insufficientResources $ + N.socket (N.addrFamily addr) N.Stream N.defaultProtocol + + invalidAddress, insufficientResources, failed :: IOException -> TransportError ConnectErrorCode + invalidAddress = TransportError ConnectNotFound . show + insufficientResources = TransportError ConnectInsufficientResources . show + failed = TransportError ConnectFailed . show +{% endhighlight %} + +Note how exceptions get mapped to `TransportErrors` using `mapExceptionID`, which is defined in `Network.Transport.Internal` as + +{% highlight haskell %} + mapExceptionIO :: (Exception e1, Exception e2) => (e1 -> e2) -> IO a -> IO a + mapExceptionIO f p = catch p (throw . f) +{% endhighlight %} + +Moreover, the original exception is used as the `String` part of the `TransportError`. This means that application developers get transport-specific feedback, which is useful for debugging, not cannot take use this transport-specific information in their _code_, which would couple applications to tightly with one specific transport implementation. diff --git a/website/wiki/otherprotocols.md b/website/wiki/otherprotocols.md new file mode 100644 index 00000000..d6e7c67a --- /dev/null +++ b/website/wiki/otherprotocols.md @@ -0,0 +1,47 @@ +--- +layout: wiki +title: Applications and other protocols +wiki: Applications +--- + +### Applications + +If you are using `Network.Transport` in your application, or if you are writing (or interested in writing) `Network.Transport` support for another protocol, please add a brief description to this page so that we can coordinate the efforts. + +### HdpH + +**H**askell **D**istributed **P**arallel **H**askell is a shallowly + embedded parallel extension of Haskell that supports high-level + semi-explicit parallelism. HdpH has a distributed memory model, that + manages computations on more than one multicore node. In addition + _high-level semi-explicit parallelism_ is supported by providing + `spark` for implicit task placement, alleviating the job of dynamic + load management to HdpH. Explicit task placement is supported with + the `pushTo` primitive. Lastly, HdpH supports the node <-> node + transfer of polymorphic closures. This enables the definition of + both evaluation strategies and algorithmic skeletons by using a + small set of polymorphic coordination primitives. + +The communication layer in HdpH adopts the `Network.Transport.TCP` +realization of the network-transport API. The HdpH implementation is +on hackage and is open source on GitHub. + +* IFL2011 paper: [Implementing a High-level Distributed-Memory Parallel Haskell in Haskell](http://www.macs.hw.ac.uk/~pm175/papers/Maier_Trinder_IFL2011_XT.pdf) +* SAC2013 paper: [Reliable Scalable Symbolic Computation: The Design of SymGridPar2](http://www.macs.hw.ac.uk/~rs46/papers/sac2013/Maier_Stewart_Trinder_SAC2013.pdf) +* Hackage: [http://hackage.haskell.org/package/hdph](http://hackage.haskell.org/package/hdph) +* Source code [https://github.com/PatrickMaier/HdpH](https://github.com/PatrickMaier/HdpH) + +# Protocol Implementations + +## CCI + +The [CCI](http://cci-forum.com) project is an open-source communication interface that aims to +provide a simple and portable API, high performance, scalability for +the largest deployments, and robustness in the presence of faults. It +is developed and maintained by a partnership of research, academic, +and industry members. + +[Parallel Scientific](http://www.parsci.com) is contributing with CCI development and promoting +its adoption as a portable API. We have developed [Haskell bindings](https://www.assembla.com/code/cci-haskell/git/nodes) for +the CCI alpha implementation, and are keen to have a CCI backend for +Cloud Haskell as resources allow. diff --git a/website/wiki/reliability.md b/website/wiki/reliability.md new file mode 100644 index 00000000..26e99b7b --- /dev/null +++ b/website/wiki/reliability.md @@ -0,0 +1,33 @@ +--- +layout: wiki +title: Fault Tolerance +wiki: reliability +--- + +### Reliability + +We do not consider the presence of side effects a barrier to fault tolerance +and automated process restarts. We **do** recognise that it's easier to +reason about restarting remote processes if they're stateless, and so we +provide a wrapper for the `ManagedProcess` API that ensures all user defined +callbacks are side effect free. + +The choice, about whether or not it is safe to restart a process that *might* +produce side effects, is left to the user. The `ManagedProcess` API provides +explicit support for evaluating user defined callbacks when a process has +decided (for some reason) to shut down. We also give the user options about +how to initialise and/or re-initialise a process that has been previously +terminated. + +When it comes to failure recovery, we defer to Erlang's approach for handling +process failures in a generic manner, by drawing on the [OTP][1] concept of +[supervision trees][2]. Erlang's [supervisor module][3] implements a process +which supervises other processes called child processes. The supervisor process +is responsible for starting, stopping, monitoring and even restarting its +child processes. A supervisors *children* can be either worker processes or +supervisors, which allows us to build hierarchical process structures (called +supervision trees in Erlang parlance). + +[1]: http://en.wikipedia.org/wiki/Open_Telecom_Platform +[2]: http://www.erlang.org/doc/design_principles/sup_princ.html +[3]: http://www.erlang.org/doc/man/supervisor.html