├── .ghci ├── .gitignore ├── .stylish-haskell.yaml ├── .travis.yml ├── CHANGELOG.md ├── LICENCE ├── Makefile ├── README.markdown ├── Setup.hs ├── bench ├── ContentsListing.hs ├── ReaderAlgorithms.hs └── Writer.hs ├── doc └── ContentsDaemonWireFormat.md ├── lib └── Vaultaire │ ├── Broker.hs │ ├── Contents.hs │ ├── Daemon.hs │ ├── DayMap.hs │ ├── InternalStore.hs │ ├── Origin.hs │ ├── OriginMap.hs │ ├── Profiler.hs │ ├── Reader.hs │ ├── ReaderAlgorithms.hs │ ├── RollOver.hs │ └── Writer.hs ├── src ├── CommandRunners.hs ├── DaemonRunners.hs ├── DemoWave.hs ├── Inspect.hs ├── TelemetryProgram.hs └── Vault.hs ├── tests ├── ContentsTest.hs ├── DaemonTest.hs ├── DayMapTest.hs ├── IntegrationTest.hs ├── InternalStoreTest.hs ├── ProfilerTest.hs ├── ReaderAlgorithms.hs ├── ReaderTest.hs ├── TestHelpers.hs └── WriterTest.hs └── vaultaire.cabal /.ghci: -------------------------------------------------------------------------------- 1 | :set -XOverloadedStrings 2 | :set +m 3 | :set -ilib:src:tests 4 | :set -I. 5 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | tags 2 | codex.tags 3 | config.h 4 | dist/ 5 | *.prof 6 | *.mem 7 | *.hp 8 | src/Package.hs 9 | 10 | # real binaries 11 | bufferd 12 | filerd 13 | readerd 14 | telemetry 15 | vault 16 | query 17 | 18 | # test binaries 19 | check 20 | convert 21 | snippet 22 | roundtrip 23 | 24 | # other detruitus 25 | junk/ 26 | 27 | .cabal-sandbox 28 | cabal.sandbox.config 29 | cabal.config 30 | -------------------------------------------------------------------------------- /.stylish-haskell.yaml: -------------------------------------------------------------------------------- 1 | # stylish-haskell configuration file 2 | # ================================== 3 | 4 | # The stylish-haskell tool is mainly configured by specifying steps. These steps 5 | # are a list, so they have an order, and one specific step may appear more than 6 | # once (if needed). Each file is processed by these steps in the given order. 7 | steps: 8 | # Convert some ASCII sequences to their Unicode equivalents. This is disabled 9 | # by default. 10 | # - unicode_syntax: 11 | # # In order to make this work, we also need to insert the UnicodeSyntax 12 | # # language pragma. If this flag is set to true, we insert it when it's 13 | # # not already present. You may want to disable it if you configure 14 | # # language extensions using some other method than pragmas. Default: 15 | # # true. 16 | # add_language_pragma: true 17 | 18 | # Import cleanup 19 | - imports: 20 | # There are different ways we can align names and lists. 21 | # 22 | # - global: Align the import names and import list throughout the entire 23 | # file. 24 | # 25 | # - group: Only align the imports per group (a group is formed by adjacent 26 | # import lines). 27 | # 28 | # - none: Do not perform any alignment. 29 | # 30 | # Default: global. 31 | align: none 32 | 33 | # Language pragmas 34 | - language_pragmas: 35 | # We can generate different styles of language pragma lists. 36 | # 37 | # - vertical: Vertical-spaced language pragmas, one per line. 38 | # 39 | # - compact: A more compact style. 40 | # 41 | # Default: vertical. 42 | style: vertical 43 | 44 | # stylish-haskell can detect redundancy of some language pragmas. If this 45 | # is set to true, it will remove those redundant pragmas. Default: true. 46 | remove_redundant: true 47 | 48 | # Align the types in record declarations 49 | - records: {} 50 | 51 | # Replace tabs by spaces. This is disabled by default. 52 | - tabs: 53 | # Number of spaces to use for each tab. Default: 8, as specified by the 54 | # Haskell report. 55 | spaces: 8 56 | 57 | # Remove trailing whitespace 58 | - trailing_whitespace: {} 59 | 60 | # A common setting is the number of columns (parts of) code will be wrapped 61 | # to. Different steps take this into account. Default: 80. 62 | columns: 78 63 | 64 | # Sometimes, language extensions are specified in a cabal file or from the 65 | # command line instead of using language pragmas in the file. stylish-haskell 66 | # needs to be aware of these, so it can parse the file correctly. 67 | # 68 | # No language extensions are enabled by default. 69 | # language_extensions: 70 | # - TemplateHaskell 71 | # - QuasiQuotes 72 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: haskell 2 | env: 3 | - 'UBUNTU_RELEASE=saucy GHCVER=7.8.3 CABALVER=1.20' 4 | 5 | before_install: 6 | - 'sudo add-apt-repository -y "deb http://archive.ubuntu.com/ubuntu/ ${UBUNTU_RELEASE} main universe"' 7 | - 'sudo add-apt-repository -y ppa:hvr/ghc' 8 | - 'sudo apt-get update' 9 | - 'sudo apt-get install librados-dev' 10 | - 'sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER happy' 11 | - 'export PATH=/opt/ghc/$GHCVER/bin:$PATH' 12 | - sudo apt-get remove libzmq1 13 | - wget http://download.zeromq.org/zeromq-4.0.4.tar.gz 14 | - tar -xf zeromq-4.0.4.tar.gz 15 | - cd zeromq-4.0.4 16 | - ./configure 17 | - make 18 | - sudo make install 19 | - sudo su -c "echo '/usr/local/lib' > /etc/ld.so.conf.d/local.conf" 20 | - sudo ldconfig 21 | - cd .. 22 | 23 | install: 24 | - 'cabal-$CABALVER update' 25 | - 'cabal sandbox init' 26 | - 'git clone https://github.com/anchor/vaultaire-common.git ../vaultaire-common/' 27 | - 'cabal sandbox add-source ../vaultaire-common/' 28 | - 'git clone https://github.com/anchor/marquise.git ../marquise/' 29 | - 'cabal sandbox add-source ../marquise/' 30 | - 'cabal-$CABALVER install --only-dependencies --enable-tests --enable-benchmarks' 31 | 32 | script: 33 | - 'cabal-$CABALVER configure --enable-tests' 34 | - 'cabal-$CABALVER build' 35 | - 'cabal-$CABALVER sdist' 36 | - 'cabal-$CABALVER test daymap-test' 37 | - 'cabal-$CABALVER test reader-algorithms-test' 38 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # 2.6.2 2 | 3 | ## User interface 4 | 5 | - The `CEPH_KEYRING` environment variable no longer needs to be manually 6 | specified; it can be passed in as the `--keyring` command-line 7 | option to the `vault` program. 8 | 9 | - The unused `Event` type has been removed from the `Vaultaire.Writer` 10 | module. 11 | 12 | ## Telemetry 13 | 14 | - Default to hostname rather than empty string for the telemetry agent 15 | ID. 16 | 17 | # 2.6.1 18 | 19 | ## User interface 20 | 21 | To disable profiling, run ``vault --no-profiling``. By default, 22 | profiling is enabled with a period of 1s and an accuracy bound of 2048 23 | telemetric stats per second. 24 | 25 | # 2.6.0 26 | 27 | ## User interface 28 | 29 | To enable profiling when running `vault`, use the flag `'--profiling'`. 30 | Optionally, you can also specify: 31 | 32 | - The profiling period with `-period `. 33 | - The name of the daemon, with `-n `, for easy reading of 34 | telemetric reports. 35 | 36 | ## Internal changes 37 | 38 | - The broker ``String`` is replaced by a ``URI`` type from the 39 | ``network-uri`` package. It does validation and allows easy 40 | manipulation of URI strings. 41 | - Most functions that previously take a broker string, a Ceph user, a 42 | Ceph pool and a signal now take those things in a ``DaemonArgs`` sum 43 | type, which also includes a profiling interface. Use the smart 44 | constructor ``daemonArgs`` to create this sum type. 45 | -------------------------------------------------------------------------------- /LICENCE: -------------------------------------------------------------------------------- 1 | A data vault for time series metrics data. 2 | 3 | Copyright © 2013 Anchor Systems, Pty Ltd 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions 8 | are met: 9 | 10 | 1. Redistributions of source code must retain the above copyright 11 | notice, this list of conditions and the following disclaimer. 12 | 13 | 2. Redistributions in binary form must reproduce the above 14 | copyright notice, this list of conditions and the following 15 | disclaimer in the documentation and/or other materials provided 16 | with the distribution. 17 | 18 | 3. Neither the name of the project nor the names of its contributors 19 | may be used to endorse or promote products derived from this 20 | software without specific prior written permission. 21 | 22 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 23 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 24 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 25 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 26 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 27 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 28 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 29 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 30 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 31 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 32 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 33 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | all: build 2 | 3 | # 4 | # Top-level targets. This is ugly. A program to extract these from the .cabal 5 | # file would work, but is there anything easier? 6 | # 7 | 8 | vault: dist/build/vault/vault 9 | inspect: dist/build/inspect/inspect 10 | demowave: dist/build/demowave/demowave 11 | daemon-test: dist/build/daemon-test/daemon-test 12 | reader-test: dist/build/reader-test/reader-test 13 | reader-algorithms: dist/build/reader-algorithms/reader-algorithms 14 | writer-test: dist/build/writer-test/writer-test 15 | daymap-test: dist/build/daymap-test/daymap-test 16 | writer-test: dist/build/writer-test/writer-test 17 | contents-test: dist/build/contents-test/contents-test 18 | integration-test: dist/build/integration-test/integration-test 19 | client-server-test: dist/build/client-server-test/client-server-test 20 | internal-store-test: dist/build/internal-store-test/internal-store-test 21 | writer-bench: dist/build/writer-bench/writer-bench 22 | reader-bench: dist/build/reader-bench/reader-bench 23 | 24 | 25 | # 26 | # Setup 27 | # 28 | 29 | ifdef V 30 | MAKEFLAGS=-R 31 | else 32 | MAKEFLAGS=-s -R 33 | REDIRECT=2>/dev/null 34 | endif 35 | 36 | .PHONY: all build test 37 | 38 | # 39 | # Build rules. This just wraps Cabal doing its thing in a Haskell 40 | # language-specific fashion. 41 | # 42 | 43 | build: dist/setup-config tags 44 | @/bin/echo -e "CABAL\tbuild" 45 | cabal build 46 | 47 | test: dist/setup-config tags 48 | @/bin/echo -e "CABAL\ttest" 49 | cabal test 50 | 51 | dist/setup-config: vaultaire.cabal Setup.hs 52 | cabal configure \ 53 | --enable-tests \ 54 | --disable-benchmarks \ 55 | -v0 2>/dev/null || /bin/echo -e "CABAL\tinstall --only-dependencies" && cabal install --only-dependencies --enable-tests --disable-benchmarks 56 | @/bin/echo -e "CABAL\tconfigure" 57 | cabal configure \ 58 | --enable-tests \ 59 | --disable-benchmarks \ 60 | --disable-library-profiling \ 61 | --disable-executable-profiling 62 | 63 | 64 | # This will match writer-test/writer-test, so we have to strip the directory 65 | # portion off. Annoying, but you can't use two '%' in a pattern rule. 66 | dist/build/%: dist/setup-config tags $(SOURCES) 67 | @/bin/echo -e "CABAL\tbuild $@" 68 | cabal build $(notdir $@) 69 | 70 | # 71 | # Build ctags file 72 | # 73 | 74 | SOURCES=$(shell find src -name '*.hs' -type f) \ 75 | $(shell find tests -name '*.hs' -type f) \ 76 | $(shell find lib -name '*.hs' -type f) 77 | 78 | HOTHASKTAGS=$(shell which hothasktags 2>/dev/null) 79 | CTAGS=$(if $(HOTHASKTAGS),$(HOTHASKTAGS),/bin/false) 80 | 81 | tags: $(SOURCES) 82 | if [ "$(HOTHASKTAGS)" ] ; then /bin/echo -e "CTAGS\ttags" ; fi 83 | -$(CTAGS) $^ > tags $(REDIRECT) 84 | 85 | format: $(SOURCES) 86 | stylish-haskell -i $^ 87 | 88 | clean: 89 | @/bin/echo -e "CABAL\tclean" 90 | -cabal clean >/dev/null 91 | @/bin/echo -e "RM\ttemporary files" 92 | -rm -f tags 93 | -rm -f *.prof 94 | -rm -f src/Package.hs 95 | 96 | doc: 97 | cabal haddock 98 | 99 | install: 100 | cabal install 101 | -------------------------------------------------------------------------------- /README.markdown: -------------------------------------------------------------------------------- 1 | # A data vault for metrics 2 | 3 | > “I may not agree with your methodology, but I'll 5 | > store to capacity the data you apply it to.” 6 | > 7 | >   —Vaultaire, 1770 (apocryphal) 8 | 9 | # Basis for analytics 10 | 11 | Most systems that store server metrics are lossy: they average data 12 | out as they compact them in order to save space. If you're planning on 13 | doing serious analytics or predictive modelling, however, you can't be 14 | throwing away data points. We wanted a place to put metrics that wasn't 15 | lossy, allows arbitrary range querying, and would scale out without 16 | bothering anybody. 17 | 18 | Vaultaire is a data vault for system metrics, backed onto Ceph. We use it 19 | internally to store systems metrics from Nagios, OpenStack and pmacct for 20 | problem diagnosis, abnormality detection, metering/billing, forecasting 21 | and capacity planning. We're looking forward to letting clients write to 22 | it as well. 23 | 24 | # Design 25 | 26 | Vaultaire is a fault-tolerant, distributed, scalable system. A few key 27 | architectural decisions enable this: 28 | 29 | * Data points are immutable. Once you've written a metric you don't go 30 | changing it. If a business decision is made to value that data 31 | differently, then that's a job for analytics later. 32 | 33 | * Writes operations are idempotent. Under the hood we _append_ every 34 | time we write, and do de-duplication when we read. If you aren't 35 | trying to to update or sort in time order when saving points, the on 36 | disk data structures become very simple indeed. And with idempotent 37 | operations, it means that should a client not receive an 38 | acknowledgment of write it can re-send that point. 39 | 40 | * No state is held by daemons. Vaultaire has quite a number of moving 41 | parts, but all of them can be multiply provisioned and none of them 42 | carry any state, so a single failure does not take down the system. 43 | Scaling under load can be done by adding more daemons horizontally. 44 | The only place state is held is in the Ceph cluster (which, by 45 | definition, is consistent and redundant). 46 | 47 | 48 | # Deployment 49 | 50 | ## System dependencies 51 | 52 | - [librados](http://ceph.com) 53 | - [zeromq 4+](http://zeromq.org/) 54 | - [GHC 7.8.3+](https://www.haskell.org/ghc/) 55 | - [cabal](https://www.haskell.org/cabal/) 56 | 57 | ## Common packages 58 | 59 | - [vaultaire-common](https://github.com/anchor/vaultaire-common) 60 | - [marquise](https://github.com/anchor/marquise) 61 | 62 | ## Build 63 | 64 | ``` 65 | cabal sandbox init 66 | cabal sandbox add-source ../vaultaire-common 67 | cabal sandbox add-source ../marquise 68 | cabal install 69 | ``` 70 | 71 | You'll need to add the sandbox's `bin` directory to your `$PATH`, or 72 | else replace the `vault` command with a fully-qualified path. 73 | 74 | ## Running 75 | 76 | You need to run four components: the `broker`, plus one or more of each 77 | of the `writer`, `reader` and `contents` daemons. These can be on the 78 | same or different hosts, but they must all point to the same broker (if 79 | you want to make the broker highly-available, use a TCP load-balancer). 80 | 81 | The defaults assume your Rados pool is called `vaultaire`, and you're 82 | connecting with the username `vaultaire`; if this isn't the case, 83 | override with `-p` and `-u` respectively. 84 | 85 | Additionally, if your Ceph keyring is not at the default path used by 86 | librados (`/etc/ceph/keyring` as of Feburary 2015) you'll need to 87 | override it with `-k /path/to/your/keyring/file`. 88 | 89 | ``` 90 | vault -d broker # Start broker in debug mode 91 | vault -d writer -b localhost # Start writer in debug mode 92 | vault -d reader -b localhost # Start reader in debug mode 93 | vault -d contents -b localhost # Start contents daemon in debug mode 94 | ``` 95 | 96 | # Ecosystem 97 | 98 | Vaultaire on its own only provides a binary interface over ZeroMQ. To 99 | fill this gap, there's a standard ecosystem of tools to provide various 100 | interfaces: 101 | 102 | - [Chevalier](https://github.com/anchor/chevalier) - datasource search 103 | engine backed to Elasticsearch. 104 | - [Sieste](https://github.com/anchor/sieste) - RESTful web interface to 105 | datapoints and metadata (talks to Vaultaire and Chevalier). 106 | - [Marquise](https://github.com/anchor/marquise) - client library for 107 | reading and writing to Vaultaire, and the `marquised` daemon for 108 | transmitting queued datapoints. 109 | - [libmarquise](https://github.com/anchor/libmarquise) - C client 110 | library for writing datapoints, for situations where using the 111 | Haskell package is unsuitable. 112 | - [vaultaire-query](https://github.com/anchor/vaultaire-query) - 113 | analytics-focused query DSL. 114 | - [Machiavelli](https://github.com/anchor/machiavelli) - graphing 115 | engine with support for using Sieste as a backend. 116 | 117 | # Implementation 118 | 119 | This is the second major release of Vaultaire. "v2" writes directly to our 120 | production Ceph cluster (via [librados][]). The server daemons ([vaultaire][]) 121 | are written in Haskell, with client libraries available in Haskell 122 | ([marquise][]) and C ([libmarquise][]). There's a search index ([chevalier][]) 123 | backed by ElasticSearch, and a visualization pipeline where RESTful access to 124 | interpolated data points ([sieste][]) is provided by Haskell to a beautiful 125 | Ruby/JavaScript graphing front-end ([machiavelli][]) that allows you to 126 | correlate and view data streams. The [vaultaire-query][] library 127 | provides a Haskell-based DSL for analytics applications. 128 | 129 | [librados]: https://ceph.com/docs/master/architecture/ 130 | [vaultaire]: https://github.com/anchor/vaultaire 131 | [marquise]: https://github.com/anchor/marquise 132 | [libmarquise]: https://github.com/anchor/libmarquise 133 | [chevalier]: https://github.com/anchor/chevalier 134 | [sieste]: https://github.com/anchor/sieste 135 | [machiavelli]: http://anchor.github.io/machiavelli/ 136 | [vaultaire-query]: http://github.com/anchor/vaultaire-query 137 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | -- 2 | -- Common Haskell build tools 3 | -- 4 | -- Copyright © 2013-2014 Operational Dynamics Consulting, Pty Ltd and Others 5 | -- 6 | -- The code in this file, and the program it is a part of, is 7 | -- made available to you by its authors as open source software: 8 | -- you can redistribute it and/or modify it under the terms of 9 | -- the 3-clause BSD licence. 10 | -- 11 | 12 | import Data.Char (toUpper) 13 | import Distribution.PackageDescription (PackageDescription (..)) 14 | import Distribution.Simple 15 | import Distribution.Simple.LocalBuildInfo (LocalBuildInfo) 16 | import Distribution.Simple.Setup (ConfigFlags) 17 | import Distribution.System (OS (..), buildOS) 18 | import Distribution.Text (display) 19 | import System.IO (Handle, IOMode (..), hPutStrLn, withFile) 20 | 21 | main :: IO () 22 | main = defaultMainWithHooks $ simpleUserHooks { 23 | postConf = configure 24 | } 25 | 26 | {- 27 | Simple detection of which operating system we're building on; 28 | there's no need to link the Cabal logic into our library, so 29 | we output to a .hs file in src/ 30 | -} 31 | 32 | configure :: Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO () 33 | configure _ _ p _ = do 34 | withFile "src/Package.hs" WriteMode (\h -> do 35 | outputModuleHeader h 36 | discoverOperatingSystem h 37 | discoverProgramVersion h p) 38 | 39 | return () 40 | 41 | outputModuleHeader :: Handle -> IO () 42 | outputModuleHeader h = do 43 | hPutStrLn h "module Package where" 44 | 45 | discoverOperatingSystem :: Handle -> IO () 46 | discoverOperatingSystem h = do 47 | hPutStrLn h "build :: String" 48 | hPutStrLn h ("build = \"" ++ s ++ "\"") 49 | where 50 | o = buildOS 51 | 52 | s = case o of 53 | Linux -> "Linux" 54 | OSX -> "Mac OS X" 55 | Windows -> "Windows" 56 | _ -> up o 57 | 58 | up x = map toUpper (show x) 59 | 60 | discoverProgramVersion :: Handle -> PackageDescription -> IO () 61 | discoverProgramVersion h p = do 62 | hPutStrLn h "package :: String" 63 | hPutStrLn h ("package = \"" ++ n ++ "\"") 64 | hPutStrLn h "version :: String" 65 | hPutStrLn h ("version = \"" ++ s ++ "\"") 66 | where 67 | i = package p 68 | (PackageName n) = pkgName i 69 | v = pkgVersion i 70 | s = display v 71 | 72 | -------------------------------------------------------------------------------- /bench/ContentsListing.hs: -------------------------------------------------------------------------------- 1 | -- 2 | -- Copyright © 2013-2014 Anchor Systems, Pty Ltd and Others 3 | -- 4 | -- The code in this file, and the program it is a part of, is 5 | -- made available to you by its authors as open source software: 6 | -- you can redistribute it and/or modify it under the terms of 7 | -- the 3-clause BSD licence. 8 | -- 9 | 10 | {-# LANGUAGE OverloadedStrings #-} 11 | 12 | module Main where 13 | 14 | import Control.Concurrent (forkIO) 15 | import Control.Exception (throwIO) 16 | import Control.Monad 17 | import Criterion.Main 18 | import Data.ByteString (ByteString) 19 | import Marquise.Client 20 | import Marquise.Server 21 | import qualified System.ZMQ4.Monadic as ZMQ 22 | import Vaultaire.Types 23 | 24 | contentsWire :: ByteString 25 | contentsWire = 26 | "\x02\ 27 | \\x01\x00\x00\x00\x00\x00\x00\x00\ 28 | \\x04\x00\x00\x00\x00\x00\x00\x00\ 29 | \\&a:b," 30 | 31 | runTest :: Int -> IO () 32 | runTest n = 33 | withConnection "tcp://localhost:5000" $ \c -> 34 | replicateM_ n (recv c >>= either throwIO nothing) 35 | where 36 | nothing :: ContentsResponse -> IO ContentsResponse 37 | nothing = return 38 | 39 | server :: IO () 40 | server = 41 | ZMQ.runZMQ $ do 42 | s <- ZMQ.socket ZMQ.Dealer 43 | ZMQ.bind s "tcp://*:5000" 44 | forever (ZMQ.send s [] contentsWire) 45 | 46 | main :: IO () 47 | main = do 48 | void (forkIO server) 49 | 50 | defaultMain 51 | [ 52 | bench "contents 32" $ nfIO $ runTest 32 53 | , bench "contents 64" $ nfIO $ runTest 64 54 | , bench "contents 128" $ nfIO $ runTest 128 55 | , bench "contents 256" $ nfIO $ runTest 256 56 | , bench "contents 512" $ nfIO $ runTest 512 ] 57 | -------------------------------------------------------------------------------- /bench/ReaderAlgorithms.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | 3 | module Main where 4 | import Control.Monad.ST 5 | import Criterion.Main 6 | import Data.Bits 7 | import Data.ByteString (ByteString) 8 | import Data.ByteString.Lazy (toStrict) 9 | import Data.ByteString.Lazy.Builder 10 | import Data.Monoid 11 | import Data.Word 12 | import qualified Vaultaire.ReaderAlgorithms as A 13 | 14 | simplePoints :: [Word64] -> ByteString 15 | simplePoints = toStrict . toLazyByteString . mconcat . map makeSimplePoint 16 | 17 | makeSimplePoint :: Word64 -> Builder 18 | makeSimplePoint n = 19 | word64LE ((n `mod` uniqueAddresses) `clearBit` 0) -- address 20 | <> word64LE n -- time 21 | <> word64LE n -- payload 22 | where 23 | uniqueAddresses = 8 * 2 24 | 25 | runTest :: ByteString -> ByteString 26 | runTest bs = runST $ A.processBucket bs 4 minBound maxBound 27 | 28 | 29 | main :: IO () 30 | main = do 31 | let !points = simplePoints [0..174763] -- 4MB 32 | let !double_points = simplePoints [0..349526] 33 | 34 | defaultMain 35 | [ bench "simple points" $ nf runTest points 36 | , bench "simple points (double)" $ nf runTest double_points 37 | ] 38 | -------------------------------------------------------------------------------- /bench/Writer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Main where 5 | import Prelude hiding (words) 6 | 7 | import Control.Concurrent.MVar 8 | import Criterion.Main 9 | import Data.Bits 10 | import Data.ByteString (ByteString) 11 | import Data.ByteString.Lazy (toStrict) 12 | import Data.ByteString.Lazy.Builder 13 | import Data.List.NonEmpty (fromList) 14 | import Data.Monoid 15 | import Data.Word (Word64) 16 | import System.Rados.Monadic 17 | import System.ZMQ4.Monadic 18 | import TestHelpers (runTestDaemon, runTestPool) 19 | import Vaultaire.Broker 20 | import Vaultaire.Util 21 | import Vaultaire.Writer 22 | 23 | createDays :: Word64 -> Word64 -> IO () 24 | createDays simple_buckets ext_buckets = runTestPool $ do 25 | _ <- runObject "02_PONY_simple_days" $ 26 | writeFull (makeDayFile simple_buckets) 27 | _ <- runObject "02_PONY_extended_days" $ 28 | writeFull (makeDayFile ext_buckets) 29 | return () 30 | 31 | makeDayFile :: Word64 -> ByteString 32 | makeDayFile n = toStrict $ toLazyByteString b 33 | where 34 | b = word64LE 0 <> word64LE (n * 2) 35 | 36 | runTest :: ByteString -> IO [ByteString] 37 | runTest msg = 38 | runZMQ $ do 39 | s <- socket Dealer 40 | connect s "tcp://localhost:5560" 41 | sendMulti s $ fromList ["\x42", "PONY", msg] 42 | receiveMulti s 43 | 44 | simplePoints :: [Word64] -> ByteString 45 | simplePoints = toStrict . toLazyByteString . mconcat . map makeSimplePoint 46 | 47 | makeSimplePoint :: Word64 -> Builder 48 | makeSimplePoint n = 49 | word64LE ((n `mod` uniqueAddresses) `clearBit` 0) -- address 50 | <> word64LE n -- time 51 | <> word64LE n -- payload 52 | where 53 | uniqueAddresses = 1000 * 2 54 | 55 | main :: IO () 56 | main = do 57 | runTestDaemon "tcp://localhost:1234" (return ()) 58 | createDays 32 32 59 | 60 | linkThread $ runZMQ $ startProxy 61 | (Router,"tcp://*:5560") (Dealer,"tcp://*:5561") "tcp://*:5000" 62 | 63 | quit <- newEmptyMVar 64 | linkThread $ startWriter "tcp://localhost:5561" Nothing "test" 0 quit 65 | 66 | let !points = simplePoints [0..10000] 67 | 68 | defaultMain 69 | [ bench "10000 simple points over 1000 addresses" $ 70 | nfIO $ runTest points 71 | ] 72 | -------------------------------------------------------------------------------- /doc/ContentsDaemonWireFormat.md: -------------------------------------------------------------------------------- 1 | # Contents daemon wire format 2 | 3 | ## Requests 4 | 5 | A request consists of one or more bytes in a ZeroMQ message. The first 6 | byte is an opcode indicating the request type, as below: 7 | 8 | - `0x00` `ContentsListRequest` 9 | - `0x01` `GenerateNewAddress` 10 | - `0x02` `UpdateSourceTag` 11 | - `0x03` `RemoveSourceTag` 12 | 13 | For `ContentsListRequest` and `GenerateNewAddress`, the first byte is 14 | the entire request. 15 | 16 | For `UpdateSourceTag` and `RemoveSourceTag`, requests consist of at 17 | least seventeen bytes, as follows: 18 | 19 | - First byte is the opcode, as above; 20 | - Next word64 (eight bytes) is the source address; 21 | - Next word64 (eight bytes) is the length of the next segment, in 22 | bytes (little-endian); 23 | - The remainder of the message is a series of UTF8-coded tags, each tag 24 | consisting of a `key`, a colon (':'), a `value` and a comma (','). 25 | The `key` and `value` may contain any UTF8 character except the colon 26 | and the comma. 27 | -------------------------------------------------------------------------------- /lib/Vaultaire/Broker.hs: -------------------------------------------------------------------------------- 1 | module Vaultaire.Broker 2 | ( 3 | startProxy, 4 | ) where 5 | 6 | import System.Log.Logger 7 | import System.ZMQ4.Monadic 8 | 9 | -- | Start a ZMQ proxy, capture is always a Pub socket. 10 | -- 11 | -- This should never return except in the case of catastrophic failure. 12 | startProxy :: (SocketType front_t, SocketType back_t) 13 | => (front_t, String) -- ^ Frontend, clients 14 | -> (back_t, String) -- ^ Backend, workers 15 | -> String -- ^ Capture address, for debug 16 | -> ZMQ z () 17 | startProxy (front_type, front_addr) (back_type, back_addr) cap_addr = do 18 | front_s <- socket front_type 19 | back_s <- socket back_type 20 | cap_s <- socket Pub 21 | 22 | bind front_s front_addr 23 | bind back_s back_addr 24 | bind cap_s cap_addr 25 | 26 | liftIO $ infoM "Broker.startProxy" ("Broker started on " ++ front_addr) 27 | proxy front_s back_s (Just cap_s) 28 | -------------------------------------------------------------------------------- /lib/Vaultaire/Contents.hs: -------------------------------------------------------------------------------- 1 | -- 2 | -- Data vault for metrics 3 | -- 4 | -- Copyright © 2013-2014 Anchor Systems, Pty Ltd and Others 5 | -- 6 | -- The code in this file, and the program it is a part of, is 7 | -- made available to you by its authors as open source software: 8 | -- you can redistribute it and/or modify it under the terms of 9 | -- the 3-clause BSD licence. 10 | -- 11 | 12 | {-# LANGUAGE OverloadedStrings #-} 13 | {-# LANGUAGE RankNTypes #-} 14 | 15 | module Vaultaire.Contents 16 | ( -- * Contents Daemon 17 | startContents 18 | ) where 19 | 20 | import Control.Applicative 21 | import Control.Exception 22 | import Control.Monad 23 | import Data.Bits 24 | import Data.Maybe (isJust) 25 | import Data.Monoid (mempty) 26 | import Data.Word (Word64) 27 | import Pipes 28 | import System.Log.Logger 29 | import System.Random 30 | import Vaultaire.Daemon 31 | import qualified Vaultaire.InternalStore as InternalStore 32 | import Vaultaire.Types 33 | 34 | -- | Start a contents daemon, never returns. 35 | -- 36 | startContents :: DaemonArgs -> IO () 37 | startContents = flip handleMessages handleRequest 38 | 39 | -- | Perform the action requested in the 'Message' and send the 40 | -- appropriate response to the client. 41 | handleRequest :: Message -> Daemon () 42 | handleRequest (Message reply origin payload) = 43 | case fromWire payload of 44 | Left err -> liftIO $ errorM "Contents.handleRequest" $ 45 | "bad request: " ++ show err 46 | Right op -> case op of 47 | ContentsListRequest -> profileCount ContentsEnumerate origin 48 | >> performListRequest reply origin 49 | 50 | GenerateNewAddress -> performRegisterRequest reply origin 51 | 52 | UpdateSourceTag a s -> profileCount ContentsUpdate origin 53 | >> performUpdateRequest reply origin a s 54 | 55 | RemoveSourceTag a s -> performRemoveRequest reply origin a s 56 | 57 | {- 58 | For the given address, read all the contents entries matching it. The 59 | latest entry is deemed most correct. Return that blob. No attempt is made 60 | to decode it; after all, the only way it could get in there is via the 61 | update or remove opcodes. 62 | 63 | The use of a Pipe here allows us to stream the responses back to the 64 | requesting client. Note that reply with Response can be used multiple 65 | times, so each reply here represents one Address,SourceDict pair. 66 | -} 67 | performListRequest :: ReplyF -> Origin -> Daemon () 68 | performListRequest reply o 69 | = profileTime ContentsEnumerateLatency o $ do 70 | 71 | liftIO $ infoM "Contents.performListRequest" 72 | (show o ++ " ContentsListRequest") 73 | 74 | runEffect $ for (InternalStore.enumerateOrigin o) 75 | (lift . reply . uncurry ContentsListBypass) 76 | reply EndOfContentsList 77 | 78 | -- | A request has been made to allocate a new unique address; do this 79 | -- and return it to the client. 80 | performRegisterRequest :: ReplyF -> Origin -> Daemon () 81 | performRegisterRequest reply o = do 82 | liftIO $ infoM "Contents.performRegisterRequest" 83 | (show o ++ " RegisterListRequest") 84 | 85 | allocateNewAddressInVault o >>= reply . RandomAddress 86 | 87 | -- | Generate a random address, make sure it's unused, and write an 88 | -- empty source dict for it so it is no longer unused. 89 | allocateNewAddressInVault :: Origin -> Daemon Address 90 | allocateNewAddressInVault o = do 91 | a <- Address . (`clearBit` 0) <$> liftIO rollDice 92 | 93 | withLockExclusive "02_addresses_lock" $ do 94 | exists <- isAddressInVault a 95 | if exists 96 | then allocateNewAddressInVault o 97 | else do 98 | writeSourceTagsForAddress o a mempty 99 | return a 100 | where 101 | rollDice = getStdRandom (randomR (0, maxBound :: Word64)) 102 | isAddressInVault a = isJust <$> InternalStore.readFrom o a 103 | 104 | -- | Update the sourcedict associated with the provided address. New 105 | -- tags will be added; new values for existing names will be updated 106 | -- (in the case of sourcedict objects only, last write wins); 107 | -- no tags will be removed. 108 | performUpdateRequest 109 | :: ReplyF 110 | -> Origin 111 | -> Address 112 | -> SourceDict 113 | -> Daemon () 114 | performUpdateRequest reply o a input 115 | = profileTime ContentsUpdateLatency o $ do 116 | 117 | liftIO $ infoM "Contents.performUpdateRequest" 118 | (show o ++ " UpdateRequest " ++ show a) 119 | 120 | (result, readTime) <- elapsed $ retreiveSourceTagsForAddress o a 121 | 122 | case result of 123 | Nothing -> do 124 | (_, writeTime) <- elapsed $ writeSourceTagsForAddress o a input 125 | -- NOTE: measurement of Ceph latency for Contents is not as accurate as 126 | -- for Reader/Writer, since these times include cycles spent in 127 | -- Reader/Writer as well as Rados. 128 | profileReport ContentsUpdateCeph o (readTime + writeTime) 129 | 130 | Just current -> do 131 | -- items in first SourceDict (the passed in update from user) win 132 | let update = unionSource input current 133 | unless (current == update) (writeSourceTagsForAddress o a update) 134 | reply UpdateSuccess 135 | 136 | -- | Remove the tags specified in the provided sourcedict from the 137 | -- provided address. Tags not specified in the provided sourcedict 138 | -- will remain. 139 | performRemoveRequest 140 | :: ReplyF 141 | -> Origin 142 | -> Address 143 | -> SourceDict 144 | -> Daemon () 145 | performRemoveRequest reply o a input = do 146 | liftIO $ infoM "Contents.performRemoveRequest" 147 | (show o ++ " RemoveRequest " ++ show a) 148 | 149 | result <- retreiveSourceTagsForAddress o a 150 | -- elements of first SourceDict not appearing in second remain 151 | case result of 152 | Nothing -> return () 153 | Just current -> do 154 | let update = diffSource current input 155 | unless (current == update) (writeSourceTagsForAddress o a update) 156 | 157 | liftIO $ infoM "Contents.performRemoveRequest" 158 | (show o ++ " Complete") 159 | reply RemoveSuccess 160 | 161 | -- | Read the sourcedict associated with an address. 162 | retreiveSourceTagsForAddress :: Origin -> Address -> Daemon (Maybe SourceDict) 163 | retreiveSourceTagsForAddress o a = do 164 | result <- InternalStore.readFrom o a 165 | return $ case result of 166 | Just b' -> either throw Just (fromWire b') 167 | Nothing -> Nothing 168 | 169 | -- | Pack the tags in the provided sourcedict and write them to Ceph. 170 | -- This will overwrite any previously-associated sourcedict for that 171 | -- address. 172 | writeSourceTagsForAddress :: Origin -> Address -> SourceDict -> Daemon () 173 | writeSourceTagsForAddress o a s = do 174 | liftIO $ infoM "Contents.writeSourceTagsForAddress" 175 | (show o ++ " Writing SourceDict") 176 | 177 | InternalStore.writeTo o a (toWire s) 178 | -------------------------------------------------------------------------------- /lib/Vaultaire/Daemon.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE Rank2Types #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | 6 | -- | Encapsulates runtime requirements of a generic vaultaire daemon 7 | -- 8 | -- Handles: 9 | -- 10 | -- * connection to ceph, 11 | -- 12 | -- * message retrieval/reply. 13 | -- 14 | -- * caching of an Origin specific DayMap 15 | module Vaultaire.Daemon 16 | ( 17 | -- * Types 18 | Daemon, 19 | DaemonArgs(..), 20 | DaemonEnv, 21 | Message(..), 22 | ReplyF, 23 | Address(..), 24 | Payload, 25 | Bucket, 26 | BucketSize, 27 | -- * Functions 28 | runDaemon, 29 | handleMessages, 30 | liftPool, 31 | nextMessage, 32 | asyncCustom, 33 | refreshOriginDays, 34 | withSimpleDayMap, 35 | withExtendedDayMap, 36 | withLockShared, 37 | withLockExclusive, 38 | cacheExpired, 39 | -- * Helpers 40 | dayMapsFromCeph, 41 | simpleDayOID, 42 | extendedDayOID, 43 | bucketOID, 44 | withPool, 45 | profileTime, 46 | profileCount, 47 | profileCountN, 48 | profileReport, 49 | elapsed, 50 | -- * Smart constructors 51 | daemonArgs, 52 | daemonArgsDefault 53 | ) where 54 | 55 | import Control.Applicative 56 | import Control.Concurrent 57 | import Control.Concurrent.Async 58 | import Control.Exception 59 | import Control.Monad 60 | import Control.Monad.Reader 61 | import Control.Monad.State.Strict 62 | import Data.ByteString (ByteString) 63 | import qualified Data.ByteString.Char8 as BS 64 | import Data.List.NonEmpty (fromList) 65 | import Data.Maybe 66 | import Data.Monoid 67 | import Data.Word (Word64) 68 | import Network.URI 69 | import System.Log.Logger 70 | import System.Posix.Signals 71 | import System.Rados.Monadic (Pool, fileSize, parseConfig, readFull, 72 | runConnect, runObject, runObject, runPool, stat, 73 | withExclusiveLock, withSharedLock) 74 | import qualified System.Rados.Monadic as Rados 75 | import qualified System.ZMQ4 as ZMQ 76 | import Text.Printf 77 | import Vaultaire.DayMap 78 | import Vaultaire.OriginMap 79 | import Vaultaire.Profiler 80 | import Vaultaire.Types 81 | import Vaultaire.Util 82 | 83 | 84 | -- User facing API 85 | 86 | -- | The 'Daemon' monad stores per 'Origin' 'DayMap's and queues for message 87 | -- retrieval and reply. The underlying base monad is a rados 'Pool', you can 88 | -- lift to this via 'liftPool'. 89 | -- 90 | newtype Daemon a = Daemon (StateT OriginDays (ReaderT DaemonEnv Pool) a) 91 | deriving ( Functor, Applicative, Monad, MonadIO 92 | , MonadReader DaemonEnv, MonadState OriginDays) 93 | 94 | -- | Arguments needed to be supplied by user to run a daemon 95 | data DaemonArgs = DaemonArgs 96 | { broker :: URI -- ^ Broker, e.g. tcp://example.com:5550 97 | , ceph_user :: Maybe ByteString -- ^ Username for Ceph 98 | , ceph_pool :: ByteString -- ^ Pool name for Ceph 99 | , shutdown :: MVar () -- ^ Shutdown signal 100 | , profiler :: ProfilingInterface -- ^ Profiler interface to use for this daemon 101 | } 102 | 103 | -- | Environment in which to run a daemon 104 | type DaemonEnv = (SharedConnection, ProfilingInterface) 105 | 106 | -- | Handle to commuicate with the 0MQ router. 107 | type SharedConnection = MVar (ZMQ.Socket ZMQ.Router) 108 | 109 | -- | Simple and extended day maps 110 | type OriginDays = OriginMap ((FileSize, DayMap), (FileSize, DayMap)) 111 | 112 | -- | Represents a request made by a client. This could be a request to write a 113 | -- point or a query. 114 | -- 115 | -- All mesages follow the same asyncronous response, reply pattern. 116 | data Message = Message 117 | { messageReplyF :: ReplyF -- ^ Queue a reply to this message. This 118 | -- will be transmitted automatically 119 | -- at a later point. 120 | , messageOrigin :: Origin 121 | , messagePayload :: ByteString 122 | } 123 | 124 | type ReplyF = WireFormat w => w -> Daemon () 125 | type Payload = Word64 126 | type Bucket = Word64 127 | type BucketSize = Word64 128 | 129 | 130 | -- | Handle messages using an arbitrary concurrency abstraction. 131 | -- 132 | -- In order for this to behave, your message handling function must be 133 | -- stateless, there is no guarantee that it will be run in the same thread, 134 | -- thus no assumptions should be made about the DayMap from a previous request 135 | -- sticking around. 136 | -- 137 | -- This prohibits any multi-message requests, if this is what you want you had 138 | -- best define your own concurrency mechanism. 139 | -- 140 | handleMessages :: DaemonArgs -- ^ Run the daemon with these arguments 141 | -> (Message -> Daemon ()) -- ^ Handle messages with this handler 142 | -> IO () 143 | handleMessages args@(DaemonArgs{..}) f = runDaemon args loop 144 | where 145 | -- Dumb, no concurrency for now. WARNING we originally had tryReadMVar but 146 | -- it was causing non-deterministic asynchronous delayed hangs. We'll come 147 | -- back to this question. 148 | loop = do 149 | done <- isJust <$> liftIO (tryReadMVar shutdown) 150 | unless done $ do 151 | maybe_next <- nextMessage 152 | case maybe_next of 153 | Nothing -> loop 154 | Just msg -> f msg >> loop 155 | 156 | -- | Encapsulating the lifetime of a daemon. 157 | -- This will go as far as to connect to Ceph and begin listening for messages. 158 | -- 159 | runDaemon :: DaemonArgs -- ^ With these arguments 160 | -> Daemon a -- ^ Run this daemon 161 | -> IO a 162 | runDaemon DaemonArgs{..} (Daemon a) = 163 | bracket (setupSharedConnection broker) 164 | (\(ctx, conn) -> do 165 | sock <- takeMVar conn 166 | ZMQ.close sock 167 | ZMQ.shutdown ctx) 168 | (\(_, conn) -> withPool ceph_user ceph_pool 169 | $ flip runReaderT (conn, profiler) 170 | $ evalStateT a emptyOriginMap) 171 | 172 | -- Connect to ceph and run your pool action 173 | withPool :: Maybe ByteString -> ByteString -> Pool a -> IO a 174 | withPool ceph_user pool = runConnect ceph_user (parseConfig "/etc/ceph/ceph.conf") . runPool pool 175 | 176 | -- | Lift an action from the librados 'Pool' monad. 177 | liftPool :: Pool a -> Daemon a 178 | liftPool = Daemon . lift . lift 179 | 180 | -- | Pop the next message off an internal FIFO queue of messages. 181 | -- Incoming message should be four parts: 182 | -- 1. The routing information back to the broker. 183 | -- 2. The routing information back to the client, from the broker. 184 | -- 3. The the origin, unverified and unauthenticated for now. 185 | -- 4. The client's payload. 186 | nextMessage :: Daemon (Maybe Message) 187 | nextMessage = do 188 | conn <- fst <$> ask 189 | liftIO $ withMVar conn $ \c -> do 190 | result <- ZMQ.poll 10 [ZMQ.Sock c [ZMQ.In] Nothing] 191 | case result of 192 | -- Message waiting 193 | [[ZMQ.In]] -> do 194 | msg <- doRecv c 195 | 196 | case msg of 197 | -- Invalid message 198 | Nothing -> return Nothing 199 | Just (env_a, env_b, origin, payload) -> 200 | -- This can be moved out of a lambda when I fully understand this: 201 | -- http://www.haskell.org/pipermail/haskell-cafe/2012-August/103041.html 202 | let send r = flip ZMQ.sendMulti (fromList [env_a, env_b, toWire r]) 203 | in return . Just $ 204 | Message (\r -> do var <- fst <$> ask 205 | liftIO $ withMVar var (send r)) 206 | (Origin origin) 207 | payload 208 | -- Timeout, do nothing. 209 | [[]] -> return Nothing 210 | _ -> fatal "Daemon.listen" "impossible" 211 | where 212 | doRecv sock = do 213 | msg <- ZMQ.receiveMulti sock 214 | case msg of 215 | [env_a, env_b, origin, payload] -> 216 | return . Just $ (env_a, env_b, origin, payload) 217 | n -> do 218 | liftIO . errorM "Daemon.nextMessage" $ 219 | "bad message recieved, " ++ show (length n) 220 | ++ " parts; ignoring" 221 | return Nothing 222 | 223 | -- | Run an action in the 'Control.Concurrent.Async' monad. 224 | -- State will be empty and completely separated from any other thread. This is 225 | -- to avoid strange memory leaks and complexity. 226 | -- 227 | -- You do however have access to the same messaging channels, so sending and 228 | -- receiving messages will work fine and is thread safe. 229 | asyncCustom :: Daemon a -> Daemon (Async a) 230 | asyncCustom (Daemon a) = do 231 | -- TODO: Handle waiting for any 'child' threads created, as the underlying 232 | -- connection is now shared. 233 | conf <- ask 234 | liftPool $ Rados.async (runReaderT (evalStateT a emptyOriginMap) conf) 235 | 236 | -- | Fetch the simple day map for a given origin 237 | withSimpleDayMap :: Origin -> (DayMap -> a) -> Daemon (Maybe a) 238 | withSimpleDayMap origin' f = do 239 | om <- get 240 | return $ f . snd . fst <$> originLookup origin' om 241 | 242 | -- | Fetch the extended day map for a given origin 243 | withExtendedDayMap :: Origin -> (DayMap -> a) -> Daemon (Maybe a) 244 | withExtendedDayMap origin' f = do 245 | om <- get 246 | return $ f . snd . snd <$> originLookup origin' om 247 | 248 | -- | Ensure that the 'DayMap's for a given 'Origin' are up to date. 249 | refreshOriginDays :: Origin -> Daemon () 250 | refreshOriginDays origin' = do 251 | om <- get 252 | -- If we already have it, reload if modified. Otherwise we just reload. 253 | expired <- cacheExpired om origin' 254 | when expired $ reload om 255 | where 256 | reload om = do 257 | result <- liftPool $ dayMapsFromCeph origin' 258 | case result of 259 | Left e -> liftIO $ putStrLn e 260 | Right day_map -> put $ originInsert origin' day_map om 261 | 262 | {- 263 | Lock management 264 | -} 265 | 266 | -- | Lock timeout period, in seconds. 267 | timeout :: Int 268 | timeout = 600 -- 10 minutes 269 | 270 | -- | Duration of lock, in seconds. 271 | release :: Double 272 | release = fromIntegral $ timeout + 5 273 | 274 | -- 275 | -- | Take a shared lock on the specified object. Others can concurrently take 276 | -- shared locks, someone wanting an exclusive lock waits until current shared 277 | -- lockers are finished. 278 | -- 279 | withLockShared :: ByteString -> Daemon a -> Daemon a 280 | withLockShared oid daemon = do 281 | liftIO $ debugM "Daemon.withSharedLock" 282 | ("Lock shared requested " ++ BS.unpack oid) 283 | result <- wrapPool (withSharedLock oid "lock" "lock" "daemon" (Just release)) $ do 284 | liftIO $ debugM "Daemon.withSharedLock" 285 | ("Lock shared acquired " ++ BS.unpack oid) 286 | daemon 287 | liftIO $ debugM "Daemon.withSharedLock" 288 | ("Lock exclusive released " ++ BS.unpack oid) 289 | return result 290 | 291 | 292 | -- 293 | -- | Take a exclusive lock on the specified object. Waits for current shared 294 | -- lockers to release while inhibiting new shared locks by others. Then locks 295 | -- exclusively, preventing other shared or exclusive locks until finished. 296 | -- 297 | withLockExclusive :: ByteString -> Daemon a -> Daemon a 298 | withLockExclusive oid daemon = do 299 | liftIO $ debugM "Daemon.withExclusiveLock" 300 | ("Lock exclusive requested " ++ BS.unpack oid) 301 | result <- wrapPool (withExclusiveLock oid "lock" "lock" (Just release)) $ do 302 | liftIO $ debugM "Daemon.withExclusiveLock" 303 | ("Lock exclusive acquired " ++ BS.unpack oid) 304 | daemon 305 | liftIO $ debugM "Daemon.withExclusiveLock" 306 | ("Lock exclusive released " ++ BS.unpack oid) 307 | return result 308 | 309 | 310 | {- 311 | In order to grab a shared lock, we lift to the Pool monad, but to run the 312 | user's action we must re-wrap the state. Daemon state within will not be 313 | updated within the 'outer' monad until the entire action completes. You 314 | will probably never even notice this. 315 | -} 316 | 317 | wrapPool :: (Pool (a, OriginDays) -> Pool (b, OriginDays)) 318 | -> Daemon a -> Daemon b 319 | wrapPool pool_action (Daemon r) = do 320 | conf <- ask 321 | s <- get 322 | 323 | -- Start timer 324 | a <- liftIO $ async watchdog 325 | 326 | -- Carry out action with librados 327 | (r',s') <- liftPool $ pool_action (runReaderT (runStateT r s) conf) 328 | 329 | -- Completed! Don't need the watchdog anymore. 330 | liftIO $ cancel a 331 | 332 | -- Wrap up and return 333 | put s' 334 | return r' 335 | where 336 | milliseconds = 1000000 337 | 338 | watchdog :: IO () 339 | watchdog = do 340 | threadDelay $ timeout * milliseconds 341 | criticalM "Daemon.watchdog" "WATCHDOG TIMER ELAPSED" 342 | raiseSignal sigKILL 343 | 344 | 345 | 346 | -- Internal 347 | 348 | type FileSize = Word64 349 | 350 | -- | Check if a cached origin has expired. 351 | cacheExpired :: OriginDays -> Origin -> Daemon Bool 352 | cacheExpired om origin' = 353 | case originLookup origin' om of 354 | Just ((simple_size, _), (ext_size, _)) -> do 355 | simple_expired <- checkDayFile (simpleDayOID origin') simple_size 356 | if not simple_expired 357 | then checkDayFile (extendedDayOID origin') ext_size 358 | else return simple_expired 359 | Nothing -> return True 360 | where 361 | checkDayFile file expected_size = do 362 | st <- liftPool $ runObject file stat 363 | case st of 364 | Left e -> fatal "Daemon.cacheExpired" $ 365 | "Failed to stat day file: " ++ show file 366 | ++ "( " ++ show e ++ ")" 367 | Right result -> return $ fileSize result /= expected_size 368 | 369 | 370 | -- | Load a DayMap from Ceph 371 | -- 372 | -- The file size is returned along side the map for cache invalidation. 373 | dayMapsFromCeph :: Origin -> Pool (Either String ((FileSize, DayMap), (FileSize, DayMap))) 374 | dayMapsFromCeph origin' = do 375 | simple <- tryRead (simpleDayOID origin') 376 | extended <- tryRead (extendedDayOID origin') 377 | return $ (,) <$> simple <*> extended 378 | where 379 | tryRead file = do 380 | result <- runObject file readFull 381 | case result of 382 | Left e -> 383 | return $ Left $ "Failed to read day file: " ++ show file ++ 384 | " (" ++ show e ++ ")" 385 | Right contents -> 386 | tryLoad file contents 387 | 388 | tryLoad day_file contents = case loadDayMap contents of 389 | Left e -> 390 | return $ Left $ "Failed to load day file: " ++ 391 | show day_file ++ " (" ++ e ++ ")" 392 | Right day_map -> 393 | return $ Right (fromIntegral (BS.length contents), day_map) 394 | 395 | -- | Ceph object ID of the origin's Simple DayMap. 396 | simpleDayOID :: Origin -> ByteString 397 | simpleDayOID (Origin origin') = "02_" <> origin' <> "_simple_days" 398 | 399 | -- | Ceph object ID of the origin's Extended DayMap. 400 | extendedDayOID :: Origin -> ByteString 401 | extendedDayOID (Origin origin') = "02_" <> origin' <> "_extended_days" 402 | 403 | -- | Ceph object ID of the bucket at the provided epoch. 404 | bucketOID :: Origin -> Epoch -> Bucket -> String -> ByteString 405 | bucketOID (Origin origin') epoch bucket kind = BS.pack $ printf "02_%s_%020d_%020d_%s" 406 | (BS.unpack origin') 407 | bucket 408 | epoch 409 | kind 410 | 411 | -- | Build the 'SharedConnection' for use by potentially many consumers within 412 | -- this 'Daemon'. 413 | setupSharedConnection :: URI -- ^ Broker name 414 | -> IO (ZMQ.Context, SharedConnection) 415 | setupSharedConnection broker = do 416 | ctx <- ZMQ.context 417 | sock <- ZMQ.socket ctx ZMQ.Router 418 | ZMQ.connect sock $ show broker 419 | mvar <- newMVar sock 420 | return (ctx, mvar) 421 | 422 | 423 | -- Convenience/Smart constructors and interface 424 | 425 | -- | Construct necessary arguments to start a daemon 426 | daemonArgs 427 | :: URI -- ^ Full broker URI, e.g. @tcp://example.com:9990@ 428 | -> Maybe String -- ^ Ceph user 429 | -> String -- ^ Ceph pool 430 | -> MVar () -- ^ Shutdown signal 431 | -> Maybe String -- ^ Indentifiable daemon name, e.g. @vault.example.com-writer-01@ 432 | -> Maybe (Int, Period, Int) -- ^ If has profiling, (port, profile period, profiling channel bound) 433 | -> IO (DaemonArgs, ProfilingEnv) 434 | daemonArgs brokerd user pool end dname pargs = do 435 | (env, interface) <- maybe (return noProfiler) 436 | (\(pport, pperiod, pbound) 437 | -> hasProfiler ( fromMaybe mempty dname 438 | , modPort brokerd pport 439 | , pperiod 440 | , pbound 441 | , end )) pargs 442 | return ( DaemonArgs brokerd 443 | (BS.pack <$> user) 444 | (BS.pack pool) 445 | end 446 | interface 447 | , env) 448 | where -- could probably lens this, if network.uri has lens support 449 | modPort u i = u { uriAuthority = (\x -> x { uriPort = ':':show i }) <$> uriAuthority u } 450 | 451 | -- | Construct default daemon arguments, with no profiler, no name. 452 | daemonArgsDefault 453 | :: URI -- ^ Full broker URI, e.g. tcp://example.com:9999 454 | -> Maybe String -- ^ Ceph user 455 | -> String -- ^ Ceph pool 456 | -> MVar () -- ^ Shutdown Signal 457 | -> IO DaemonArgs 458 | daemonArgsDefault full_broker_uri user pool shutdown 459 | = fst <$> daemonArgs full_broker_uri user pool shutdown Nothing Nothing 460 | 461 | -- | Send a one-count for this telemtric type to the profiler for this daemon 462 | -- 463 | profileCount :: TeleMsgType -> Origin -> Daemon () 464 | profileCount t g = do 465 | (_, prof) <- ask 466 | profCount prof t g 1 467 | {-# INLINE profileCount #-} 468 | 469 | -- | Send an n-count for this telemtric type to the profiler for this daemon 470 | -- 471 | profileCountN :: TeleMsgType -> Origin -> Int -> Daemon () 472 | profileCountN t g c = do 473 | (_, prof) <- ask 474 | profCount prof t g c 475 | {-# INLINE profileCountN #-} 476 | 477 | -- | Measure the timelapse for a daemon operation and 478 | -- send the result to the profiler 479 | -- 480 | profileTime :: TeleMsgType -> Origin -> Daemon r -> Daemon r 481 | profileTime t g act = do 482 | (_, prof) <- ask 483 | profTime prof t g act 484 | {-# INLINE profileTime #-} 485 | 486 | -- | Measure the timelapse for a daemon operation. 487 | -- 488 | elapsed :: Daemon r -> Daemon (r, Word64) 489 | elapsed act = do 490 | (_, prof) <- ask 491 | measureTime prof act 492 | {-# INLINE elapsed #-} 493 | 494 | profileReport :: TeleMsgType -> Origin -> Word64 -> Daemon () 495 | profileReport t g p = do 496 | (_, prof) <- ask 497 | report prof t g p 498 | {-# INLINE profileReport #-} 499 | -------------------------------------------------------------------------------- /lib/Vaultaire/DayMap.hs: -------------------------------------------------------------------------------- 1 | module Vaultaire.DayMap 2 | ( 3 | DayMap(..), 4 | NumBuckets, 5 | Epoch, 6 | lookupFirst, 7 | lookupRange, 8 | loadDayMap 9 | ) where 10 | 11 | import Control.Applicative 12 | import Data.ByteString (ByteString) 13 | import qualified Data.ByteString as BS 14 | import qualified Data.Map as Map 15 | import Data.Packer 16 | import Vaultaire.Types 17 | 18 | -- | Parses a DayMap. Simple corruption check of input is done by 19 | -- checking that it is a multiple of two Word64s; Left is returned if 20 | -- corruption is detected, or if the provided ByteString is empty. 21 | loadDayMap :: ByteString -> Either String DayMap 22 | loadDayMap bs 23 | | BS.null bs = 24 | Left "empty" 25 | | BS.length bs `rem` 16 /= 0 = 26 | Left $ "corrupt contents, should be multiple of 16, was: " ++ 27 | show (BS.length bs) ++ " bytes." 28 | | otherwise = 29 | let loaded = mustLoadDayMap bs 30 | (first, _) = Map.findMin (unDayMap loaded) 31 | in if first == 0 32 | then Right loaded 33 | else Left "bad first entry, must start at zero." 34 | 35 | -- | Finds the first entry in the provided 'DayMap' that's after the 36 | -- provided 'TimeStamp'. 37 | lookupFirst :: TimeStamp -> DayMap -> (Epoch, NumBuckets) 38 | lookupFirst start dm = fst $ splitRemainder start dm 39 | 40 | -- | Return first entry and the remainder that is later than the provided 41 | -- 'TimeStamp'. 42 | splitRemainder :: TimeStamp -> DayMap -> ((Epoch, NumBuckets), DayMap) 43 | splitRemainder (TimeStamp t) (DayMap m) = 44 | let (left, middle, right) = Map.splitLookup t m 45 | first = case middle of 46 | Just n -> if Map.null left -- Corner case, leftmost entry 47 | then (t, n) 48 | else Map.findMax left 49 | Nothing -> Map.findMax left 50 | in (first, DayMap right) 51 | 52 | -- | Get the DayMap entries between two TimeStamps. 53 | lookupRange :: TimeStamp -> TimeStamp -> DayMap -> [(Epoch, NumBuckets)] 54 | lookupRange start (TimeStamp end) dm = 55 | let (first, DayMap remainder) = splitRemainder start dm 56 | (rest,_) = Map.split end remainder 57 | in first : Map.toList rest 58 | 59 | -- Internal 60 | 61 | -- | Unpack a ByteString consisting of one or more 62 | -- ('Epoch','NumBuckets') pairs into a 'DayMap'. Will throw an 63 | -- 'OutOfBoundUnpacking' error on badly-formed data. 64 | mustLoadDayMap :: ByteString -> DayMap 65 | mustLoadDayMap = 66 | DayMap . Map.fromList . runUnpacking parse 67 | where 68 | parse = many $ (,) <$> getWord64LE <*> getWord64LE 69 | -------------------------------------------------------------------------------- /lib/Vaultaire/InternalStore.hs: -------------------------------------------------------------------------------- 1 | -- 2 | -- Data vault for metrics 3 | -- 4 | -- Copyright © 2013-2014 Anchor Systems, Pty Ltd and Others 5 | -- 6 | -- The code in this file, and the program it is a part of, is 7 | -- made available to you by its authors as open source software: 8 | -- you can redistribute it and/or modify it under the terms of 9 | -- the 3-clause BSD licence. 10 | -- 11 | 12 | {-# LANGUAGE OverloadedStrings #-} 13 | 14 | -- | This is a way for vaultaire components to store data within the Vault 15 | -- itself. 16 | module Vaultaire.InternalStore 17 | ( 18 | writeTo, 19 | readFrom, 20 | enumerateOrigin, 21 | internalStoreBuckets 22 | ) where 23 | 24 | import Control.Monad.State.Strict 25 | import Data.ByteString (ByteString) 26 | import qualified Data.ByteString.Char8 as BS 27 | import Data.Monoid 28 | import Data.Packer 29 | import Data.Time 30 | import Data.Word (Word64) 31 | import Pipes 32 | import Pipes.Parse 33 | import qualified Pipes.Prelude as Pipes 34 | import Vaultaire.Daemon (Daemon, profileTime) 35 | import Vaultaire.Origin 36 | import Vaultaire.Reader (getBuckets, readExtendedInternal) 37 | import Vaultaire.ReaderAlgorithms (mergeNoFilter) 38 | import Vaultaire.Types 39 | import Vaultaire.Writer (BatchState (..), appendExtended, write) 40 | 41 | -- | Given an origin and an address, write the given bytes. 42 | writeTo :: Origin -> Address -> ByteString -> Daemon () 43 | writeTo origin addr payload = 44 | write Internal origin False makeState 45 | where 46 | makeState :: BatchState 47 | makeState = 48 | let zt = UTCTime (ModifiedJulianDay 0) 0 in -- kind of dumb 49 | let empty = BatchState mempty mempty mempty 0 0 mempty 0 zt in 50 | let bucket = calculateBucketNumber internalStoreBuckets addr in 51 | let len = fromIntegral $ BS.length payload in 52 | execState (appendExtended 0 bucket addr 0 len payload) empty 53 | 54 | -- | To save bootstrapping the system with actual day map files we will simply 55 | -- mod this value. This could be a scaling issue with huge data sets. 56 | internalStoreBuckets :: Word64 57 | internalStoreBuckets = 128 58 | 59 | -- | Given an origin and an address, read the avaliable bytes. 60 | readFrom :: Origin -> Address -> Daemon (Maybe ByteString) 61 | readFrom origin addr = 62 | evalStateT draw $ yield (0, internalStoreBuckets) 63 | >-> readExtendedInternal origin addr 0 0 64 | >-> Pipes.map extractPayload 65 | where 66 | extractPayload bs = attemptUnpacking bs $ do 67 | unpackSetPosition 16 68 | len <- getWord64LE 69 | getBytes (fromIntegral len) 70 | 71 | attemptUnpacking bs a = 72 | case tryUnpacking a bs of 73 | Left e -> error $ "failed to unpack internal payload: " ++ show e 74 | Right v -> v 75 | 76 | -- | Provide a Producer of address and payload tuples. 77 | enumerateOrigin :: Origin -> Producer (Address, ByteString) Daemon () 78 | enumerateOrigin origin = 79 | forM_ [0,2..internalStoreBuckets] $ \bucket -> do 80 | -- This is using the Reader so the profiled time is not exactly just 81 | -- Ceph waiting time, but also some reader checking. 82 | buckets <- lift $ profileTime ContentsEnumerateCeph origin 83 | $ getBuckets Internal origin 0 bucket 84 | case buckets of 85 | Nothing -> return () 86 | Just (s,e) -> mergeNoFilter s e 87 | -------------------------------------------------------------------------------- /lib/Vaultaire/Origin.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | {-| 4 | Low-level origin-related definitions which should not be exposed to 5 | clients (and therefore don't belong in Vaultaire.Types). 6 | -} 7 | module Vaultaire.Origin 8 | ( 9 | namespaceOrigin, 10 | Namespace(..) 11 | ) where 12 | 13 | import Data.ByteString (ByteString) 14 | import qualified Data.ByteString.Char8 as BS 15 | 16 | import Vaultaire.Types 17 | 18 | -- | Suffix appended to the origin segment of a bucket name to indicate 19 | -- that it's for internal use. 20 | internalNamespace :: ByteString 21 | internalNamespace = "_INTERNAL" 22 | 23 | -- | Convert a raw origin to the raw origin used as a bucket prefix. If 24 | -- the desired operation is on an internal bucket, the origin is 25 | -- qualified with the appropriate suffix; if not, it is returned 26 | -- unmodified. 27 | namespaceOrigin :: Namespace -- ^ Is the operation internal or external? 28 | -> Origin -- ^ Base origin (of the form returned by 29 | -- 'makeOrigin') 30 | -> Origin 31 | namespaceOrigin Internal = Origin . (`BS.append` internalNamespace) . unOrigin 32 | namespaceOrigin External = id 33 | 34 | -- | An origin has both Internal and External buckets. Regular 35 | -- simple and extended points written by clients go in External 36 | -- buckets; Internal buckets are not directly accessible by clients 37 | -- and are used under the hood to store metadata. 38 | data Namespace = Internal | External 39 | -------------------------------------------------------------------------------- /lib/Vaultaire/OriginMap.hs: -------------------------------------------------------------------------------- 1 | module Vaultaire.OriginMap 2 | ( 3 | OriginMap, 4 | originLookup, 5 | originInsert, 6 | originDelete, 7 | emptyOriginMap, 8 | ) where 9 | 10 | import Data.HashMap.Strict (HashMap) 11 | import qualified Data.HashMap.Strict as HashMap 12 | 13 | import Vaultaire.Types 14 | 15 | type OriginMap = HashMap Origin 16 | 17 | originLookup :: Origin -> OriginMap a -> Maybe a 18 | originLookup = HashMap.lookup 19 | 20 | -- TODO: Unbackwards this 21 | originInsert :: Origin -> a -> OriginMap a -> OriginMap a 22 | originInsert = HashMap.insert 23 | 24 | originDelete :: Origin -> OriginMap a -> OriginMap a 25 | originDelete = HashMap.delete 26 | 27 | emptyOriginMap :: OriginMap a 28 | emptyOriginMap = HashMap.empty 29 | -------------------------------------------------------------------------------- /lib/Vaultaire/Profiler.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TupleSections #-} 7 | 8 | module Vaultaire.Profiler 9 | ( Profiler 10 | , ProfilerArgs 11 | , ProfilingEnv 12 | , ProfilingInterface(..) 13 | , Period 14 | , startProfiler 15 | , noProfiler 16 | , hasProfiler ) 17 | where 18 | 19 | import Control.Applicative 20 | import Control.Concurrent hiding (yield) 21 | import Control.Monad.Reader 22 | import Control.Monad.State.Strict 23 | import qualified Data.Map.Strict as M 24 | import Data.Maybe 25 | import Data.Monoid 26 | import Data.UnixTime 27 | import Data.Word 28 | import Foreign.C.Types (CTime (..)) 29 | import Network.URI 30 | import Pipes 31 | import Pipes.Concurrent 32 | import Pipes.Lift 33 | import Pipes.Parse (foldAll) 34 | import System.Log.Logger 35 | import qualified System.ZMQ4 as Z 36 | 37 | import Vaultaire.Types 38 | 39 | -- | The profiler will publish on this socket. 40 | type PublishSock = Z.Socket Z.Pub 41 | 42 | type Period = Int 43 | 44 | -- | A profile action, with access to the internal connections. 45 | newtype Profiler a = Profiler (ReaderT ProfilingEnv IO a) 46 | deriving ( Functor, Applicative, Monad, MonadIO 47 | , MonadReader ProfilingEnv ) 48 | 49 | -- | Use the environment to run a profiler action. 50 | -- *NOTE* this is destructive w.r.t the environment, afterwards 51 | -- the environment cannot be reused for another profiler. 52 | -- 53 | runProfiler :: ProfilingEnv -> Profiler a -> IO a 54 | runProfiler e (Profiler x) = do 55 | debugM "Profiler.runProfiler" "Profiler starting." 56 | r <- runReaderT x e 57 | _ <- _seal e 58 | debugM "Profiler.runProfiler" "Profiler sealed and cleaned up." 59 | return r 60 | 61 | -- | Runs the profiling loop which reads reports from the worker and 62 | -- publishes them via ZeroMQ. 63 | startProfiler :: ProfilingEnv -> IO () 64 | startProfiler env@(ProfilingEnv{..}) = 65 | Z.withContext $ \ctx -> 66 | Z.withSocket ctx Z.Pub $ \sock -> do 67 | Z.connect sock $ show _publish 68 | runProfiler env $ profile sock 69 | 70 | -- | Interface exposed to worker threads so they can report to the profiler. 71 | -- in case of no profiling, these functions should be basically noops. 72 | data ProfilingInterface = ProfilingInterface 73 | { -- Reporting functions, they will perform the necessary measurements 74 | -- and send them to the profiler. 75 | profCount :: MonadIO m => TeleMsgType -> Origin -> Int -> m () 76 | -- ^ Queue sending a count profiling message. 77 | , profTime :: MonadIO m => TeleMsgType -> Origin -> m r -> m r 78 | -- ^ Report the time taken by an action. 79 | -- Raw measurement and sending functions. 80 | , measureTime :: MonadIO m => m r -> m (r, Word64) 81 | -- ^ Measure the time elapsed for the provided action (in ms). 82 | , report :: MonadIO m => TeleMsgType -> Origin -> Word64 -> m () } 83 | -- ^ Send a profiling report to be queued. 84 | 85 | -- | Arguments needed to be specified by the user for profiling 86 | -- (name, publishing port, period, bound, shutdown signal). 87 | type ProfilerArgs = (String, URI, Period, Int, MVar ()) 88 | 89 | -- | Profiling environment. 90 | data ProfilingEnv = ProfilingEnv 91 | { _aname :: AgentID -- ^ Identifiable name for this daemon 92 | , _publish :: URI -- ^ Broker for telemetrics 93 | , _bound :: Int -- ^ Max telemetric messages from worker per period 94 | , _sleep :: Int -- ^ Period, in milliseconds 95 | , _output :: Output ChanMsg -- ^ Send to the profiler via this output 96 | , _input :: Input ChanMsg -- ^ Receive messages sent to the profiler via this input 97 | , _seal :: IO () -- ^ Seal the profiler chan 98 | , _shutdown :: MVar () -- ^ Shutdown signal 99 | } 100 | 101 | -- | Values that can be sent to the profiling channel. 102 | data ChanMsg = Barrier 103 | | Tele TeleMsg 104 | deriving Show 105 | 106 | -- | Dummy profiler, does nothing. 107 | noProfiler :: (ProfilingEnv, ProfilingInterface) 108 | noProfiler 109 | = ( ProfilingEnv 110 | { _aname = mempty 111 | , _publish = nullURI 112 | , _bound = 0 113 | , _sleep = 0 114 | , _output = Output { send = const $ return False } 115 | , _input = Input { recv = return Nothing } 116 | , _seal = return () 117 | -- This is fine because this MVar will never be read 118 | -- the profiling environment accessors are not exported. 119 | , _shutdown = undefined } 120 | , ProfilingInterface 121 | { profCount = const $ const $ const $ return () 122 | , profTime = const $ const id 123 | , measureTime = (>>= return . (,0)) 124 | , report = const $ const $ const $ return () } ) 125 | 126 | -- | Builds a (real, not-dummy) profiler interface. If the agent name 127 | -- provided is invalid, an empty name will be used. 128 | hasProfiler :: ProfilerArgs -> IO (ProfilingEnv, ProfilingInterface) 129 | hasProfiler (name, broker, period, bound, quit) = do 130 | let logEmpty = do 131 | errorM "Daemon.setupProfiler" 132 | ("The daemon name given is invalid: " ++ name ++ 133 | ". An empty name has been given to the daemon.") 134 | return mempty 135 | n <- maybe logEmpty return (agentID name) 136 | -- We use the @Newest@ buffer for the internal report queue 137 | -- so that old reports will be removed if the buffer is full. 138 | -- This means the profiler will lose precision but not have 139 | -- an impact on performance if there is too much activity. 140 | (output, input, sealchan) <- spawn' $ Newest bound 141 | return ( ProfilingEnv 142 | { _aname = n 143 | , _publish = broker 144 | , _bound = bound 145 | , _sleep = period 146 | , _output = output 147 | , _input = input 148 | , _seal = liftIO $ atomically sealchan 149 | , _shutdown = quit } 150 | , ProfilingInterface 151 | { profCount = sendCount output 152 | , profTime = sendElapsed output 153 | , measureTime = elapsed 154 | , report = sendIt output } ) 155 | 156 | where sendCount output teletype origin count = do 157 | -- sending to the profiler shouldn't fail (as the buffer is @Newest@) 158 | -- but if it does there is nothing the worker could do about it 159 | _ <- liftIO $ atomically $ send output 160 | $ Tele $ TeleMsg origin teletype $ fromIntegral count 161 | return () 162 | 163 | sendIt output teletype origin payload = do 164 | _ <- liftIO $ atomically $ send output 165 | $ Tele $ TeleMsg origin teletype payload 166 | return () 167 | 168 | elapsed act = do 169 | !t1 <- liftIO getUnixTime 170 | r <- act 171 | !t2 <- liftIO getUnixTime 172 | return (r, diffTimeInMs $ diffUnixTime t2 t1) 173 | 174 | sendElapsed output teletype origin act = do 175 | (r, t) <- elapsed act 176 | _ <- liftIO $ atomically $ send output $ Tele 177 | $ TeleMsg origin teletype t 178 | return r 179 | 180 | diffTimeInMs :: UnixDiffTime -> Word64 181 | diffTimeInMs u 182 | = let secInMilliSec = raw (udtSeconds u) * 1000 183 | uSecInMilliSec = udtMicroSeconds u `div` 1000 184 | in fromIntegral $ secInMilliSec + fromIntegral uSecInMilliSec 185 | raw (CTime x) = x 186 | 187 | -- | Reads profiling reports waiting in the channel, packs them into 188 | -- 'TeleResp' messages and publishes them on the provided socket. 189 | profile :: PublishSock -> Profiler () 190 | profile sock = do 191 | ProfilingEnv{..} <- ask 192 | 193 | done <- isJust <$> liftIO (tryReadMVar _shutdown) 194 | unless done $ do 195 | -- Read at most N reports from the profiling channel (N = size of the channel) 196 | -- since new reports would still be coming in after we have commenced this operation. 197 | _ <- liftIO $ atomically $ send _output Barrier 198 | msgs <- aggregate $ fromInputUntil _bound _input 199 | _ <- mapM (mkResp _aname >=> pub) msgs 200 | 201 | -- Sleep for milliseconds 202 | liftIO $ milliDelay _sleep 203 | profile sock 204 | 205 | where mkResp :: MonadIO m => AgentID -> TeleMsg -> m TeleResp 206 | mkResp n msg = do 207 | t <- liftIO getCurrentTimeNanoseconds 208 | return $ TeleResp t n msg 209 | 210 | pub :: TeleResp -> Profiler () 211 | pub resp = liftIO $ do 212 | debugM "Profiler.profile" "Publishing a telemetric" 213 | Z.send sock [] $ toWire resp 214 | 215 | -- | Reads from input until we either hit a barrier or reach the cap. 216 | -- Like pipes-concurrency's @fromInput@ but non-blocking. 217 | fromInputUntil :: MonadIO m => Int -> Input ChanMsg -> Producer TeleMsg m () 218 | fromInputUntil n chan = evalStateP 0 go 219 | where go = do 220 | x <- lift get 221 | when (x <= n) $ do 222 | a <- liftIO $ atomically $ recv chan 223 | case a of Just (Tele t) -> yield t >> lift (put (x + 1)) >> go 224 | _ -> return () 225 | 226 | -- | Aggregate telemetric reports, guaranteed to process only N reports. 227 | -- 228 | -- *NOTE* Technically we do not need to report number of requests received, 229 | -- since we can just count the number of latency samples, 230 | -- but to keep things simple and modular we will leave them separate. 231 | aggregate :: Monad m => Producer TeleMsg m () -> m [TeleMsg] 232 | aggregate = evalStateT $ foldAll 233 | (\acc x -> M.insertWith (go $ _type x) (_origin x, _type x) (1, _payload x) acc) 234 | (M.empty) 235 | (map (uncurry extract) . M.toList) 236 | where go WriterSimplePoints = count 237 | go WriterExtendedPoints = count 238 | go WriterRequest = count 239 | go WriterRequestLatency = keep 240 | go WriterCephLatency = keep 241 | go ReaderSimplePoints = count 242 | go ReaderExtendedPoints = count 243 | go ReaderRequest = count 244 | go ReaderRequestLatency = keep 245 | go ReaderCephLatency = keep 246 | go ContentsEnumerate = count 247 | go ContentsUpdate = count 248 | go ContentsEnumerateLatency = keep 249 | go ContentsUpdateLatency = keep 250 | go ContentsEnumerateCeph = keep 251 | go ContentsUpdateCeph = keep 252 | extract k@(_, WriterSimplePoints ) = msg k <$> (snd ) 253 | extract k@(_, WriterExtendedPoints ) = msg k <$> (snd ) 254 | extract k@(_, WriterRequest ) = msg k <$> (snd ) 255 | extract k@(_, WriterRequestLatency ) = msg k <$> (div <$> snd <*> fst) 256 | extract k@(_, WriterCephLatency ) = msg k <$> (div <$> snd <*> fst) 257 | extract k@(_, ReaderSimplePoints ) = msg k <$> (snd ) 258 | extract k@(_, ReaderExtendedPoints ) = msg k <$> (snd ) 259 | extract k@(_, ReaderRequest ) = msg k <$> (snd ) 260 | extract k@(_, ReaderRequestLatency ) = msg k <$> (div <$> snd <*> fst) 261 | extract k@(_, ReaderCephLatency ) = msg k <$> (div <$> snd <*> fst) 262 | extract k@(_, ContentsEnumerate ) = msg k <$> (snd ) 263 | extract k@(_, ContentsUpdate ) = msg k <$> (snd ) 264 | extract k@(_, ContentsEnumerateLatency) = msg k <$> (div <$> snd <*> fst) 265 | extract k@(_, ContentsUpdateLatency ) = msg k <$> (div <$> snd <*> fst) 266 | extract k@(_, ContentsEnumerateCeph ) = msg k <$> (div <$> snd <*> fst) 267 | extract k@(_, ContentsUpdateCeph ) = msg k <$> (div <$> snd <*> fst) 268 | count (_, v1) (_, v2) = (0, v1 + v2) 269 | keep (c1, v1) (c2, v2) = (c1 + c2, v1 + v2) 270 | msg (x,y) z = TeleMsg x y z 271 | 272 | -- | Suspends current thread for one millisecond. 273 | milliDelay :: Int -> IO () 274 | milliDelay = threadDelay . (*1000) 275 | -------------------------------------------------------------------------------- /lib/Vaultaire/Reader.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | 4 | module Vaultaire.Reader 5 | ( 6 | startReader, 7 | readExtended, 8 | readExtendedInternal, 9 | getBuckets, 10 | ) where 11 | 12 | import Control.Applicative 13 | import Control.Monad 14 | import Control.Monad.Cont 15 | import Control.Monad.ST 16 | import Data.ByteString (ByteString) 17 | import qualified Data.ByteString as S 18 | import Pipes 19 | import System.Log.Logger 20 | import System.Rados.Monadic 21 | 22 | import Vaultaire.Daemon 23 | import Vaultaire.DayMap 24 | import Vaultaire.Origin 25 | import Vaultaire.ReaderAlgorithms (mergeSimpleExtended, processBucket) 26 | import Vaultaire.Types 27 | 28 | -- | Start a writer daemon, never returns. 29 | startReader :: DaemonArgs -> IO () 30 | startReader = flip handleMessages handleRequest 31 | 32 | -- | Accepts a request 'Message' from a client (either Simple or 33 | -- Extended) and replies with a response terminated by 'EndOfStream'. 34 | handleRequest :: Message -> Daemon () 35 | handleRequest (Message reply_f origin payload) 36 | = profileTime ReaderRequestLatency origin $ do 37 | profileCount ReaderRequest origin 38 | 39 | case fromWire payload of 40 | Right req -> do 41 | liftIO $ infoM "Reader.handleRequest" (show origin ++ " Read " ++ show req) 42 | case req of 43 | SimpleReadRequest addr start end -> 44 | processSimple addr start end origin reply_f 45 | ExtendedReadRequest addr start end -> 46 | processExtended addr start end origin reply_f 47 | reply_f EndOfStream 48 | Left e -> 49 | liftIO . errorM "Reader.handleRequest" $ 50 | "failed to decode request: " ++ show e 51 | 52 | -- | Yields the ByteString argument to the output Pipe if it's not 53 | -- empty; otherwise yields nothing. 54 | yieldNotNull :: Monad m => ByteString -> Pipe i ByteString m () 55 | yieldNotNull bs = unless (S.null bs) (yield bs) 56 | 57 | -- | processSimple handles a request for a series of simple points, 58 | -- sending the result back to the client. 59 | processSimple :: Address -> TimeStamp -> TimeStamp -> Origin -> ReplyF -> Daemon () 60 | processSimple addr start end origin reply_f = do 61 | profileCount ReaderSimplePoints origin 62 | 63 | refreshOriginDays origin 64 | maybe_range <- withSimpleDayMap origin (lookupRange start end) 65 | 66 | case maybe_range of 67 | Just range -> 68 | runEffect $ for (each range >-> readSimple origin addr start end) 69 | (lift . reply_f . SimpleStream . SimpleBurst) 70 | Nothing -> reply_f InvalidReadOrigin 71 | 72 | -- | readSimple reads SimplePoints in a given time range from the vault. 73 | -- Cannot be used to read from internal (contents) buckets; regular 74 | -- time series only. 75 | readSimple :: Origin -> Address -> TimeStamp -> TimeStamp 76 | -> Pipe (Epoch, NumBuckets) ByteString Daemon () 77 | readSimple origin addr start end = forever $ do 78 | (epoch, num_buckets) <- await 79 | let bucket = calculateBucketNumber num_buckets addr 80 | let bucket_oid = bucketOID origin epoch bucket "simple" 81 | contents <- lift $ profileTime ReaderCephLatency origin 82 | $ liftPool $ runObject bucket_oid readFull 83 | case contents of 84 | Left (NoEntity{}) -> return () 85 | Left e -> 86 | liftIO $ errorM "Reader.readSimple" $ 87 | "Ceph error getting simple bucket: " ++ show e 88 | Right unprocessed -> do 89 | let bs = runST $ processBucket unprocessed addr start end 90 | -- This division should have no remainer, as the bytestring should 91 | -- contain whole simple points. If not, it's garbage. 92 | lift $ profileCountN ReaderSimplePoints origin (S.length bs `div` 24) 93 | yieldNotNull bs 94 | 95 | -- | processExtended handles a read request for a series of extended 96 | -- points, sending a response back to the client. 97 | processExtended :: Address -> TimeStamp -> TimeStamp -> Origin -> ReplyF -> Daemon () 98 | processExtended addr start end origin reply_f = do 99 | refreshOriginDays origin 100 | maybe_range <- withExtendedDayMap origin (lookupRange start end) 101 | case maybe_range of 102 | Just range -> 103 | runEffect $ for (each range >-> readExtended origin addr start end) 104 | (lift . reply_f . ExtendedStream . ExtendedBurst) 105 | Nothing -> reply_f InvalidReadOrigin 106 | 107 | -- | readExtended' reads extended points from either an internal or an 108 | -- external bucket, depending on the value of the first parameter. 109 | readExtended' :: Namespace 110 | -> Origin 111 | -> Address 112 | -> TimeStamp 113 | -> TimeStamp 114 | -> Pipe (Epoch, NumBuckets) ByteString Daemon () 115 | readExtended' ns origin addr start end = forever $ do 116 | (epoch, num_buckets) <- await 117 | let bucket = calculateBucketNumber num_buckets addr 118 | buckets <- lift $ getBuckets ns origin epoch bucket 119 | case buckets of 120 | Nothing -> return () 121 | Just (s,e) -> do 122 | let bs = runST $ mergeSimpleExtended s e addr start end 123 | lift $ profileCountN ReaderExtendedPoints origin (S.length bs `div` 24) 124 | yieldNotNull bs 125 | 126 | -- | readExtended reads ExtendedPoints in a given time range. Cannot be 127 | -- used to read internal buckets. 128 | readExtended :: Origin -> Address -> TimeStamp -> TimeStamp 129 | -> Pipe (Epoch, NumBuckets) ByteString Daemon () 130 | readExtended = readExtended' External 131 | 132 | -- | readExtendedInternal reads internal ExtendedPoints in a given time range. 133 | -- Cannot be used to read regular buckets. 134 | readExtendedInternal :: Origin -> Address -> TimeStamp -> TimeStamp 135 | -> Pipe (Epoch, NumBuckets) ByteString Daemon () 136 | readExtendedInternal = readExtended' Internal 137 | 138 | -- | Retrieve simple and extended buckets in parallel. Can be used for 139 | -- either regular or internal buckets (controlled by the 'internal' 140 | -- flag). 141 | getBuckets :: Namespace 142 | -> Origin 143 | -> Epoch 144 | -> Bucket 145 | -> Daemon (Maybe (ByteString, ByteString)) 146 | getBuckets ns origin epoch bucket = do 147 | let namespaced_origin = namespaceOrigin ns origin 148 | let simple_oid = bucketOID namespaced_origin epoch bucket "simple" 149 | let extended_oid = bucketOID namespaced_origin epoch bucket "extended" 150 | 151 | -- Request both async 152 | (a_simple, a_extended) <- profileTime ReaderCephLatency origin 153 | $ liftPool $ runAsync 154 | $ (,) <$> runObject simple_oid readFull 155 | <*> runObject extended_oid readFull 156 | 157 | -- Check both errors 158 | maybe_simple <- look a_simple >>= (\c -> case c of 159 | Left (NoEntity{}) -> return Nothing 160 | Left e -> do 161 | liftIO $ errorM "Reader.getBuckets" $ 162 | "Ceph error getting simple bucket: " ++ show e 163 | return Nothing 164 | Right unprocessed -> return $ Just unprocessed) 165 | 166 | maybe_extended <- look a_extended >>= (\c -> case c of 167 | Left (NoEntity{}) -> return Nothing 168 | Left e -> do 169 | liftIO $ errorM "Reader.getBuckets" $ 170 | "Ceph error getting extended bucket: " ++ show e 171 | return Nothing 172 | Right unprocessed -> return $ Just unprocessed) 173 | 174 | return $ (,) <$> maybe_simple <*> maybe_extended 175 | -------------------------------------------------------------------------------- /lib/Vaultaire/ReaderAlgorithms.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | 4 | module Vaultaire.ReaderAlgorithms 5 | ( 6 | deDuplicate, 7 | Point(..), 8 | processBucket, 9 | mergeSimpleExtended, 10 | mergeNoFilter, 11 | similar, 12 | deDuplicateLast, 13 | ) where 14 | 15 | import Control.Applicative 16 | import Control.Monad 17 | import Control.Monad.Primitive 18 | import Control.Monad.ST (runST) 19 | import Data.ByteString (ByteString) 20 | import Data.ByteString.Lazy (toStrict) 21 | import Data.ByteString.Lazy.Builder 22 | import Data.Monoid 23 | import Data.Packer 24 | import qualified Data.Vector.Algorithms.Merge as M 25 | import Data.Vector.Generic.Mutable (MVector) 26 | import qualified Data.Vector.Generic.Mutable as M 27 | import qualified Data.Vector.Storable as V 28 | import Data.Vector.Storable.ByteString 29 | import Data.Word 30 | import Foreign.Ptr 31 | import Foreign.Storable 32 | import Pipes 33 | import Prelude hiding (filter) 34 | 35 | import Vaultaire.Types 36 | 37 | data Point = Point { address :: !Word64 38 | , time :: !Word64 39 | , payload :: !Word64 40 | } deriving (Show, Eq) 41 | 42 | instance Storable Point where 43 | sizeOf _ = 24 44 | alignment _ = 8 45 | peek ptr = 46 | Point <$> peek (castPtr ptr) 47 | <*> peek (ptr `plusPtr` 8) 48 | <*> peek (ptr `plusPtr` 16) 49 | poke ptr (Point a t p) = do 50 | poke (castPtr ptr) a 51 | poke (ptr `plusPtr` 8 ) t 52 | poke (ptr `plusPtr` 16 ) p 53 | 54 | instance Ord Point where 55 | -- Compare time first, then address. This way we can de-deplicate by 56 | -- comparing adjacent values. 57 | compare a b = 58 | case compare (time a) (time b) of 59 | EQ -> compare (address a) (address b) 60 | c -> c 61 | 62 | -- | Is the address and time the same? We don't care about the payload 63 | similar :: Point -> Point -> Bool 64 | similar a b = (address a == address b) && (time a == time b) 65 | 66 | -- | Sort and de-duplicate elements. First element wins. 67 | deDuplicate :: (PrimMonad m, MVector v e, Ord e) 68 | => (e -> e -> Bool) 69 | -> v (PrimState m) e 70 | -> m (v (PrimState m) e) 71 | deDuplicate cmp input 72 | | M.null input = return input 73 | | otherwise = do 74 | first <- M.unsafeRead input 0 75 | go input first 1 1 (M.length input) 76 | where 77 | go buf prev_elt read_ptr write_ptr len 78 | | read_ptr == len = return $ M.take write_ptr buf 79 | | otherwise = do 80 | elt <- M.unsafeRead buf read_ptr 81 | 82 | if elt `cmp` prev_elt 83 | then 84 | go buf prev_elt (succ read_ptr) write_ptr len 85 | else do 86 | -- This conditional is an optimization for non-duplicate 87 | -- data. 88 | when (write_ptr /= read_ptr) $ 89 | M.unsafeWrite buf write_ptr elt 90 | 91 | go buf elt (succ read_ptr) (succ write_ptr) len 92 | 93 | -- 94 | -- | Sort and de-duplicate elements. Last element wins. 95 | deDuplicateLast :: (PrimMonad m, MVector v e, Ord e, Eq e) 96 | => (e -> e -> Bool) 97 | -> v (PrimState m) e 98 | -> m (v (PrimState m) e) 99 | deDuplicateLast cmp input 100 | | M.null input = return input 101 | | otherwise = do 102 | first <- M.unsafeRead input 0 103 | go input first 1 0 (M.length input) 104 | where 105 | go buf prev_elt read_ptr write_ptr len 106 | | read_ptr == len = do 107 | -- Copy last element, it's always not-duplicate or the last in a 108 | -- duplicate block. 109 | M.unsafeRead buf (pred len) >>= M.unsafeWrite buf write_ptr 110 | return $ M.take (succ write_ptr) buf 111 | | otherwise = do 112 | elt <- M.unsafeRead buf read_ptr 113 | 114 | -- Skip duplicates, reading ahead by one. Skip by not incrementing 115 | -- write pointer. 116 | if prev_elt `cmp` elt 117 | then 118 | go buf elt (succ read_ptr) write_ptr len 119 | else do 120 | M.unsafeWrite buf write_ptr prev_elt 121 | go buf elt (succ read_ptr) (succ write_ptr) len 122 | 123 | 124 | -- | Filter and de-duplicate a bucket in-place. The original bytestring will be 125 | -- garbage after completion. 126 | processBucket :: (PrimMonad m) 127 | => ByteString -> Address -> TimeStamp -> TimeStamp -> m ByteString 128 | processBucket bucket (Address addr) (TimeStamp start) (TimeStamp end) = do 129 | let v = byteStringToVector bucket 130 | let v' = V.filter (\p -> address p == addr && time p >= start && time p <= end) v 131 | mv <- V.thaw v' 132 | M.sort mv 133 | v'' <- deDuplicate similar mv >>= V.freeze 134 | return $ vectorToByteString v'' 135 | 136 | -- | Merge a simple and extended bucket into one bytestring, suitable for wire 137 | -- transfer. 138 | mergeSimpleExtended :: (PrimMonad m) 139 | => ByteString -> ByteString 140 | -> Address -> TimeStamp -> TimeStamp 141 | -> m ByteString 142 | mergeSimpleExtended simple extended addr start end = do 143 | de_duped <- byteStringToVector `liftM` processBucket simple addr start end 144 | return $ toStrict $ toLazyByteString $ V.foldl' merge mempty de_duped 145 | where 146 | merge acc (Point addr' time' os) = 147 | let bytes = runUnpacking (getExtendedBytes os) extended 148 | bldr = word64LE addr' <> word64LE time' <> byteString bytes 149 | in acc <> bldr 150 | 151 | -- | Producer for the the whole bucket, no filtering, returns only addresses 152 | -- and payloads. This is used for the internal store, where last writes win. 153 | mergeNoFilter :: (Monad m) 154 | => ByteString -> ByteString 155 | -> Producer (Address, ByteString) m () 156 | mergeNoFilter simple extended = do 157 | let de_duped = runST $ preProcess simple 158 | V.forM_ de_duped $ \(Point addr _ os) -> 159 | let bytes = runUnpacking (getExtendedPayloadOnly os) extended 160 | in yield (Address addr, bytes) 161 | where 162 | preProcess bs = V.thaw (byteStringToVector bs :: V.Vector Point) 163 | >>= (\v -> M.sort v 164 | >> deDuplicateLast similar v) 165 | >>= V.freeze 166 | 167 | -- First word is the length, then the string. We return the length and the 168 | -- string as a string. 169 | getExtendedBytes :: Word64 -> Unpacking ByteString 170 | getExtendedBytes offset = do 171 | unpackSetPosition (fromIntegral offset) 172 | len <- getWord64LE 173 | unpackSetPosition (fromIntegral offset) 174 | getBytes (fromIntegral len + 8) 175 | 176 | -- First word is the length, then the string. We return just the string. 177 | getExtendedPayloadOnly :: Word64 -> Unpacking ByteString 178 | getExtendedPayloadOnly offset = do 179 | unpackSetPosition (fromIntegral offset) 180 | len <- getWord64LE 181 | getBytes (fromIntegral len) 182 | -------------------------------------------------------------------------------- /lib/Vaultaire/RollOver.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | -- | Day file related rollover actions. Daemons writing to the vault will want 3 | -- this. 4 | module Vaultaire.RollOver 5 | ( 6 | rollOverSimpleDay, 7 | rollOverExtendedDay, 8 | updateSimpleLatest, 9 | updateExtendedLatest, 10 | originLockOID, 11 | ) where 12 | 13 | import Control.Monad.State 14 | import Data.ByteString (ByteString) 15 | import qualified Data.ByteString as BS 16 | import Data.Monoid 17 | import Data.Packer 18 | import System.Rados.Monadic 19 | import Vaultaire.Daemon 20 | import Vaultaire.DayMap 21 | import Vaultaire.Types 22 | 23 | -- | Roll the cluster onto a new "vault day", this will block until all other 24 | -- daemons are synchronized at acquiring any shared locks. 25 | -- 26 | -- All day maps will be invalidated on roll over, it is up to you to ensure 27 | -- that they are reloaded before next use. 28 | rollOverSimpleDay :: Origin -> NumBuckets -> Daemon () 29 | rollOverSimpleDay origin' = 30 | rollOver origin' (simpleDayOID origin') (simpleLatestOID origin') 31 | 32 | -- | Equivalent of 'rollOverSimpleDay' for extended buckets. 33 | rollOverExtendedDay :: Origin -> NumBuckets -> Daemon () 34 | rollOverExtendedDay origin' = 35 | rollOver origin' (extendedDayOID origin') (extendedLatestOID origin') 36 | 37 | -- | This compares the given time against the latest one in ceph, and updates 38 | -- if larger. 39 | -- 40 | -- You should only call this once with the maximum time of whatever data set 41 | -- you are writing down. This should be done within the same lock as that 42 | -- write. 43 | updateSimpleLatest :: Origin -> TimeStamp -> Daemon () 44 | updateSimpleLatest origin' = updateLatest (simpleLatestOID origin') 45 | 46 | -- | Equivalent of 'updateSimpleLatest' for extended buckets. 47 | updateExtendedLatest :: Origin -> TimeStamp -> Daemon () 48 | updateExtendedLatest origin' = updateLatest (extendedLatestOID origin') 49 | 50 | -- Internal 51 | 52 | -- | Updates the latest time specified Ceph object to the provided 53 | -- 'TimeStamp', if it is later than the one the object already has. 54 | updateLatest :: ByteString -> TimeStamp -> Daemon () 55 | updateLatest oid (TimeStamp time) = withLockExclusive oid . liftPool $ do 56 | result <- runObject oid readFull 57 | case result of 58 | Right v -> when (parse v < time) doWrite 59 | Left (NoEntity{}) -> doWrite 60 | Left e -> error $ show e 61 | where 62 | doWrite = 63 | runObject oid (writeFull value) 64 | >>= maybe (return ()) (error.show) 65 | value = runPacking 8 (putWord64LE time) 66 | parse = either (const 0) id . tryUnpacking getWord64LE 67 | 68 | -- | Roll an origin over to a new "vault day" - append an entry to the 69 | -- 'DayMap' file with the most recent timestamp and bucket count. 70 | rollOver :: Origin -> ByteString -> ByteString -> NumBuckets -> Daemon () 71 | rollOver origin day_file latest_file buckets = 72 | withLockExclusive (originLockOID origin) $ do 73 | om <- get 74 | expired <- cacheExpired om origin 75 | unless expired $ do 76 | latest <- liftPool $ runObject latest_file readFull >>= mustLatest 77 | 78 | when (BS.length latest /= 8) $ 79 | error $ "corrupt latest file in origin': " ++ show origin 80 | 81 | app <- liftPool . runObject day_file $ 82 | append (latest <> build buckets) 83 | 84 | case app of 85 | Just e -> error $ "failed to append for rollover: " ++ show e 86 | Nothing -> return () 87 | where 88 | build n = runPacking 8 $ putWord64LE n 89 | mustLatest = either (\e -> error $ "could not get latest_file" ++ show e) 90 | return 91 | 92 | -- | Identifier of the object used to lock an origin during rollover. 93 | originLockOID :: Origin -> ByteString 94 | originLockOID = simpleLatestOID 95 | 96 | -- | Construct the ID of the Ceph object storing the timestamp of the 97 | -- latest 'SimplePoint' which was written to an origin (note that this is 98 | -- the timestamp of the point, not the time at which it was written). 99 | simpleLatestOID :: Origin -> ByteString 100 | simpleLatestOID (Origin origin') = 101 | "02_" <> origin' <> "_simple_latest" 102 | 103 | -- | Analogous to 'simpleLatestOID' for extended points. 104 | extendedLatestOID :: Origin -> ByteString 105 | extendedLatestOID (Origin origin') = 106 | "02_" <> origin' <> "_extended_latest" 107 | -------------------------------------------------------------------------------- /lib/Vaultaire/Writer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE RecordWildCards #-} 6 | 7 | module Vaultaire.Writer 8 | ( 9 | startWriter, 10 | -- Testing 11 | processPoints, 12 | appendExtended, 13 | appendSimple, 14 | write, 15 | batchStateNow, 16 | BatchState(..), 17 | ) where 18 | 19 | import Control.Applicative 20 | import Control.Monad 21 | import Control.Monad.Reader 22 | import Control.Monad.State.Strict 23 | import Data.ByteString (ByteString) 24 | import qualified Data.ByteString.Char8 as S 25 | import Data.ByteString.Lazy (toStrict) 26 | import Data.ByteString.Lazy.Builder 27 | import Data.HashMap.Strict (HashMap) 28 | import qualified Data.HashMap.Strict as HashMap 29 | import Data.Monoid 30 | import Data.Packer 31 | import Data.Time 32 | import Data.Traversable (for) 33 | import Data.Word (Word64) 34 | import System.Log.Logger 35 | import System.Rados.Monadic hiding (async) 36 | import Text.Printf 37 | import Vaultaire.Daemon 38 | import Vaultaire.DayMap 39 | import Vaultaire.Origin 40 | import Vaultaire.RollOver 41 | import Vaultaire.Types 42 | import Vaultaire.Util (fatal) 43 | 44 | type EpochMap = HashMap Epoch 45 | type BucketMap = HashMap Bucket 46 | 47 | -- | State used by the writer when processing a batch of points. 48 | data BatchState = BatchState 49 | { simple :: !(EpochMap (BucketMap Builder)) 50 | , extended :: !(EpochMap (BucketMap Builder)) 51 | , pending :: !(EpochMap (BucketMap (Word64, [Word64 -> Builder]))) 52 | , latestSimple :: !TimeStamp 53 | , latestExtended :: !TimeStamp 54 | , dayMaps :: !(DayMap, DayMap) -- ^ Simple, extended 55 | , bucketSize :: !Word64 56 | , start :: !UTCTime 57 | } 58 | 59 | -- | Start a writer daemon, runs until shutdown. 60 | startWriter :: DaemonArgs -> BucketSize -> IO () 61 | startWriter args bucket_size = handleMessages args (processBatch bucket_size) 62 | 63 | -- | Gets the relevant batch state for a given BucketSize and simple 64 | -- and extended DayMaps. The 'start' time is the current time. 65 | batchStateNow :: BucketSize 66 | -> (DayMap, DayMap) -- ^ (simple daymap, extended daymap) 67 | -> IO BatchState 68 | batchStateNow bucket_size dms = 69 | BatchState mempty mempty mempty 0 0 dms bucket_size <$> getCurrentTime 70 | 71 | -- | Writes a batch of points. Will only write to regular 72 | -- (external) buckets. 73 | processBatch :: BucketSize 74 | -> Message 75 | -> Daemon () 76 | processBatch bucket_size (Message reply origin payload) 77 | = profileTime WriterRequestLatency origin $ do 78 | profileCount WriterRequest origin 79 | 80 | let bytes = S.length payload 81 | 82 | t1 <- liftIO getCurrentTime 83 | liftIO $ infoM "Writer.processBatch" 84 | (show origin ++ " Processing " ++ printf "%9d" bytes ++ " B") 85 | 86 | write_state <- withLockShared (originLockOID origin) $ do 87 | refreshOriginDays origin 88 | simple_dm <- withSimpleDayMap origin id 89 | extended_dm <- withExtendedDayMap origin id 90 | case (,) <$> simple_dm <*> extended_dm of 91 | Nothing -> return Nothing 92 | Just dms -> do 93 | -- Most messages simply need to be placed into the correct epoch 94 | -- and bucket, extended ones are a little more complex in that they 95 | -- have to be stored as an offset to a pending write to the 96 | -- extended buckets. 97 | 98 | s <- liftIO $ batchStateNow bucket_size dms 99 | let ((sp, ep), s') = flip runState s 100 | $ processPoints 0 payload (dayMaps s) origin 101 | (latestSimple s) (latestExtended s) 102 | 103 | profileCountN WriterSimplePoints origin sp 104 | profileCountN WriterExtendedPoints origin ep 105 | 106 | return $ Just s' 107 | 108 | result <- case write_state of 109 | Nothing -> reply InvalidWriteOrigin 110 | Just s -> do 111 | wt1 <- liftIO getCurrentTime 112 | profileTime WriterCephLatency origin 113 | $ write External origin True s 114 | wt2 <- liftIO getCurrentTime 115 | liftIO . debugM "Writer.processBatch" $ concat [ 116 | "Wrote simple objects at ", 117 | fmtWriteRate bytes wt2 wt1, 118 | " kB/s"] 119 | reply OnDisk 120 | 121 | t2 <- liftIO getCurrentTime 122 | let delta_padded = fmtWriteRate bytes t2 t1 123 | liftIO $ infoM "Writer.processBatch" 124 | (show origin ++ " Finished " ++ delta_padded ++ " kB/s") 125 | return result 126 | where 127 | fmtWriteRate :: Int -> UTCTime -> UTCTime -> String 128 | fmtWriteRate bytes end start = printf "%9.1f" . writeRate bytes $ diffUTCTime end start 129 | 130 | writeRate :: Int -> NominalDiffTime -> Float 131 | writeRate bytes d = ((fromRational . toRational) bytes / (fromRational . toRational) d) / 1000 132 | 133 | -- | Given a message consisting of one or more simple or extended 134 | -- points, write them to the vault. 135 | processPoints :: MonadState BatchState m 136 | => Word64 -- ^ Offset 137 | -> ByteString -- ^ Raw message 138 | -> (DayMap, DayMap) -- ^ (simple daymap, extended daymap) 139 | -> Origin -- ^ Origin to write to 140 | -> TimeStamp -- ^ Latest simple timestamp 141 | -> TimeStamp -- ^ Latest extended timestamp 142 | -> m (Int, Int) -- ^ Number of (simple, extended) points processed 143 | processPoints offset message day_maps origin latest_simple latest_ext 144 | | fromIntegral offset >= S.length message = do 145 | modify (\s -> s { latestSimple = latest_simple 146 | , latestExtended = latest_ext }) 147 | return (0,0) 148 | | otherwise = do 149 | let (address, time, payload) = runUnpacking (parseMessageAt offset) message 150 | let (simple_epoch, simple_buckets) = lookupFirst time (fst day_maps) 151 | 152 | -- The LSB of the address lets us know if it is an extended message or 153 | -- not. Set means extended. 154 | if isAddressExtended address 155 | then do 156 | let len = fromIntegral payload 157 | let str | len == 0 = "" -- will fail bounds check without this 158 | | otherwise = 159 | runUnpacking (getBytesAt (offset + 24) len) message 160 | let (ext_epoch, ext_buckets) = lookupFirst time (snd day_maps) 161 | let ext_bucket = calculateBucketNumber ext_buckets address 162 | appendExtended ext_epoch ext_bucket address time len str 163 | let !t | time > latest_ext = time 164 | | otherwise = latest_ext 165 | (s,e) <- processPoints (offset + 24 + len) message day_maps origin latest_simple t 166 | return (s,e+1) 167 | 168 | else do 169 | let message_bytes = runUnpacking (getBytesAt offset 24) message 170 | let simple_bucket = calculateBucketNumber simple_buckets address 171 | appendSimple simple_epoch simple_bucket message_bytes 172 | let !t | time > latest_simple = time 173 | | otherwise = latest_simple 174 | (s,e) <- processPoints (offset + 24) message day_maps origin t latest_ext 175 | return (s+1,e) 176 | 177 | -- | Unpacks a message starting from the given offset. If it corresponds 178 | -- to a simple point, the 'Payload' will be the value; if extended, 179 | -- the 'Payload' will be the number of bytes in the value. 180 | parseMessageAt :: Word64 -> Unpacking (Address, TimeStamp, Payload) 181 | parseMessageAt offset = do 182 | unpackSetPosition (fromIntegral offset) 183 | (,,) <$> (Address <$> getWord64LE) <*> (TimeStamp <$> getWord64LE) <*> getWord64LE 184 | 185 | -- | Gets the specified number of bytes, starting from the specified 186 | -- offset. 187 | getBytesAt :: Word64 -- ^ Offset 188 | -> Word64 -- ^ Number of bytes 189 | -> Unpacking ByteString 190 | getBytesAt offset len = do 191 | unpackSetPosition (fromIntegral offset) 192 | getBytes (fromIntegral len) 193 | 194 | -- | This one is pretty simple, simply append to the builder within the bucket 195 | -- map, which is within an epoch map itself. Yes, this is two map lookups per 196 | -- insert. 197 | appendSimple :: MonadState BatchState m 198 | => Epoch -> Bucket -> ByteString -> m () 199 | appendSimple epoch bucket bytes = do 200 | s <- get 201 | let builder = byteString bytes 202 | let simple_map = HashMap.lookupDefault HashMap.empty epoch (simple s) 203 | let simple_map' = HashMap.insertWith (flip (<>)) bucket builder simple_map 204 | let !simple' = HashMap.insert epoch simple_map' (simple s) 205 | put $ s { simple = simple' } 206 | 207 | -- | Analogous to 'appendSimple' for extended points. 208 | appendExtended :: MonadState BatchState m 209 | => Epoch -> Bucket -> Address -> TimeStamp -> Word64 -> ByteString -> m () 210 | appendExtended epoch bucket (Address address) (TimeStamp time) len string = do 211 | s <- get 212 | 213 | -- First we write to the simple bucket, inserting a closure that will 214 | -- return a builder given an offset of the extended bucket write. 215 | let pending_map = HashMap.lookupDefault HashMap.empty epoch (pending s) 216 | 217 | -- Starting from zero, we write to the current offset and point the next 218 | -- extended point to the end of that write. 219 | let (os, fs) = HashMap.lookupDefault (0, []) bucket pending_map 220 | let os' = os + len + 8 221 | 222 | -- Create the closure for the pointer to the extended bucket 223 | let prefix = word64LE address <> word64LE time 224 | let fs' = (\base_offset -> prefix <> word64LE (base_offset + os)):fs 225 | 226 | -- Update the bucket, 227 | let pending_map' = HashMap.insert bucket (os', fs') pending_map 228 | let pending' = HashMap.insert epoch pending_map' (pending s) 229 | 230 | -- Now the data goes into the extended bucket. 231 | let builder = word64LE len <> byteString string 232 | let ext_map= HashMap.lookupDefault HashMap.empty epoch (extended s) 233 | let ext_map' = HashMap.insertWith (flip (<>)) bucket builder ext_map 234 | let extended' = HashMap.insert epoch ext_map' (extended s) 235 | 236 | put $ s { pending = pending', extended = extended' } 237 | 238 | -- | Write happens in three stages: 239 | -- 1. Extended buckets are written to disk and the offset is noted. 240 | -- 2. Simple buckets are written to disk with the pending writes applied. 241 | -- 3. Acks are sent 242 | -- 4. Any rollovers are done 243 | -- 244 | -- This function is used to write both internal and external buckets; 245 | -- this is controlled by the first parameter. 246 | write :: Namespace 247 | -> Origin 248 | -> Bool 249 | -> BatchState 250 | -> Daemon () 251 | write ns origin do_rollovers s = do 252 | let namespaced_origin = namespaceOrigin ns origin 253 | extended_offsets <- writeExtendedBuckets namespaced_origin 254 | 255 | let simple_buckets = applyOffsets extended_offsets (simple s) (pending s) 256 | simple_offsets <- stepTwo simple_buckets namespaced_origin 257 | 258 | -- Update latest files after the writes have gone down to disk, in case 259 | -- something happens between now and sending all the acks. 260 | when do_rollovers $ do 261 | updateSimpleLatest namespaced_origin (latestSimple s) 262 | updateExtendedLatest namespaced_origin (latestExtended s) 263 | 264 | -- 4. Do any rollovers 265 | when do_rollovers $ do 266 | let limit = bucketSize s 267 | -- We want to ensure that the rollover only happens if an offset is 268 | -- exceeded for the latest epoch, otherwise we get duplicate 269 | -- rollovers. 270 | (simple_epoch, n_simple_buckets) <- getLatestEpoch withSimpleDayMap namespaced_origin 271 | (extended_epoch, n_extended_buckets) <- getLatestEpoch withExtendedDayMap namespaced_origin 272 | 273 | when (offsetExceeded simple_offsets simple_epoch limit) 274 | (rollOverSimpleDay namespaced_origin n_simple_buckets) 275 | when (offsetExceeded extended_offsets extended_epoch limit) 276 | (rollOverExtendedDay namespaced_origin n_extended_buckets) 277 | where 278 | getLatestEpoch f o = 279 | f o (lookupFirst maxBound) >>= mustBucket 280 | 281 | mustBucket = maybe (error "could not find n_buckets for roll over") return 282 | 283 | offsetExceeded offsetss epoch limit = 284 | case HashMap.lookup epoch offsetss of 285 | Nothing -> 286 | -- The latest epoch wasn't written to this time, so we don't 287 | -- need to rollover. 288 | False 289 | Just offsets -> 290 | HashMap.foldr max 0 offsets > limit 291 | 292 | -- 1. Write extended buckets. We lock the entire origin for write as we 293 | -- will be operating on most buckets most of the time. 294 | writeExtendedBuckets o = 295 | withLockExclusive (writeLockOID o) $ liftPool $ do 296 | -- First pass to get current offsets 297 | offsets <- forWithKey (extended s) $ \epoch buckets -> do 298 | 299 | -- Make requests for the entire epoch 300 | liftIO $ debugM "Writer.writeExtendedBuckets" "Stat extended objects" 301 | stats <- forWithKey buckets $ \bucket _ -> 302 | extendedOffset o epoch bucket 303 | 304 | -- Then extract the fileSize from those requests 305 | for stats $ \async_stat -> do 306 | result <- look async_stat 307 | case result of 308 | Left (NoEntity{..}) -> 309 | return 0 310 | Left e -> 311 | fatal "Writer.writeExtendedBuckets" $ 312 | "extended bucket stat: " ++ show e 313 | Right st -> 314 | return $ fileSize st 315 | 316 | -- Second pass to write the extended data 317 | _ <- forWithKey (extended s) $ \epoch buckets -> do 318 | liftIO $ debugM "Writer.writeExtendedBuckets" "Write extended objects" 319 | writes <- forWithKey buckets $ \bucket builder -> do 320 | let payload = toStrict $ toLazyByteString builder 321 | writeExtended o epoch bucket payload 322 | 323 | for writes $ \async_write -> do 324 | result <- waitSafe async_write 325 | case result of 326 | Just e -> fatal "Writer.writeExtendedBuckets" $ 327 | "extended bucket write: " ++ show e 328 | Nothing -> return () 329 | 330 | return offsets 331 | 332 | -- Given two maps, one of offsets and one of closures, we walk through 333 | -- applying one to the other. We then append that to the map of simple 334 | -- writes in order to achieve one write. 335 | applyOffsets offset_map = 336 | HashMap.foldlWithKey' applyEpochs 337 | where 338 | applyEpochs simple_map' epoch = 339 | HashMap.foldlWithKey' (applyBuckets epoch) simple_map' 340 | 341 | applyBuckets epoch simple_map'' bucket (_, fs) = 342 | let offset = HashMap.lookup epoch offset_map >>= HashMap.lookup bucket 343 | simple_buckets = HashMap.lookupDefault HashMap.empty epoch simple_map'' 344 | in case offset of 345 | Nothing -> fatal "Writer.applyOffsets" 346 | "No offset for extended point!" 347 | Just os -> 348 | let builder = mconcat $ reverse $ map ($os) fs 349 | simple_buckets' = HashMap.insertWith (<>) bucket builder simple_buckets 350 | in HashMap.insert epoch simple_buckets' simple_map'' 351 | 352 | -- Final write, 353 | stepTwo simple_buckets o = liftPool $ 354 | forWithKey simple_buckets $ \epoch buckets -> do 355 | liftIO $ debugM "Writer.stepTwo" "Write simple objects" 356 | writes <- forWithKey buckets $ \bucket builder -> do 357 | let payload = toStrict $ toLazyByteString builder 358 | writeSimple o epoch bucket payload 359 | for writes $ \(async_stat, async_write) -> do 360 | w <- waitSafe async_write 361 | case w of 362 | Just e -> fatal "Writer.stepTwo" $ 363 | "simple bucket write: " ++ show e 364 | Nothing -> do 365 | r <- look async_stat 366 | case r of 367 | Left NoEntity{} -> return 0 368 | Left e -> fatal "Writer.stepTwo" $ 369 | "simple bucket read: " ++ show e 370 | Right st -> return $ fileSize st 371 | 372 | forWithKey = flip HashMap.traverseWithKey 373 | 374 | -- | Get the file size and mtime of an extended bucket. 375 | extendedOffset :: Origin -> Epoch -> Bucket -> Pool (AsyncRead StatResult) 376 | extendedOffset o e b = 377 | runAsync $ runObject (bucketOID o e b "extended") stat 378 | 379 | -- | Writes an extended point to a bucket. 380 | writeExtended :: Origin -> Epoch -> Bucket -> ByteString -> Pool AsyncWrite 381 | writeExtended o e b payload = 382 | runAsync $ runObject (bucketOID o e b "extended") (append payload) 383 | 384 | -- | Writes a simple point to a bucket. 385 | writeSimple :: Origin -> Epoch -> Bucket -> ByteString -> Pool (AsyncRead StatResult, AsyncWrite) 386 | writeSimple o e b payload = 387 | runAsync $ runObject (bucketOID o e b "simple") $ 388 | (,) <$> stat <*> append payload 389 | 390 | -- | Object ID of the write lock object for an origin. 391 | writeLockOID :: Origin -> ByteString 392 | writeLockOID (Origin o') = 393 | "02_" <> o' <> "_write_lock" 394 | -------------------------------------------------------------------------------- /src/CommandRunners.hs: -------------------------------------------------------------------------------- 1 | -- 2 | -- Data vault for metrics 3 | -- 4 | -- Copyright © 2013-2014 Anchor Systems, Pty Ltd and Others 5 | -- 6 | -- The code in this file, and the program it is a part of, is 7 | -- made available to you by its authors as open source software: 8 | -- you can redistribute it and/or modify it under the terms of 9 | -- the 3-clause BSD licence. 10 | -- 11 | 12 | {-# LANGUAGE RankNTypes #-} 13 | 14 | module CommandRunners 15 | ( 16 | runDumpDayMap, 17 | runRegisterOrigin 18 | ) where 19 | 20 | import Control.Exception (throw) 21 | import Control.Monad 22 | import qualified Data.ByteString.Char8 as S 23 | import Data.Map (fromAscList) 24 | import Data.Word (Word64) 25 | import Marquise.Client 26 | import Pipes 27 | import System.Log.Logger 28 | import System.Rados.Monadic (RadosError (..), runObject, stat, writeFull) 29 | import Vaultaire.Daemon (dayMapsFromCeph, extendedDayOID, simpleDayOID, 30 | withPool) 31 | import Vaultaire.Types 32 | 33 | 34 | runDumpDayMap :: String -> String -> Origin -> IO () 35 | runDumpDayMap pool user origin = do 36 | let user' = Just (S.pack user) 37 | let pool' = S.pack pool 38 | 39 | maps <- withPool user' pool' (dayMapsFromCeph origin) 40 | case maps of 41 | Left e -> error e 42 | Right ((_, simple), (_, extended)) -> do 43 | putStrLn "Simple day map:" 44 | print simple 45 | putStrLn "Extended day map:" 46 | print extended 47 | 48 | runRegisterOrigin :: String -> String -> Origin -> Word64 -> Word64 -> TimeStamp -> TimeStamp -> IO () 49 | runRegisterOrigin pool user origin buckets step (TimeStamp begin) (TimeStamp end) = do 50 | let targets = [simpleDayOID origin, extendedDayOID origin] 51 | let user' = Just (S.pack user) 52 | let pool' = S.pack pool 53 | 54 | withPool user' pool' (forM_ targets initializeDayMap) 55 | where 56 | initializeDayMap target = 57 | runObject target $ do 58 | result <- stat 59 | case result of 60 | Left NoEntity{} -> return () 61 | Left e -> throw e 62 | Right _ -> liftIO $ infoM "Commands.runRegisterOrigin" ("Target already in place (" ++ S.unpack target ++ ")") 63 | 64 | writeFull (toWire dayMap) >>= maybe (return ()) throw 65 | 66 | dayMap = DayMap . fromAscList $ 67 | ((0, buckets):)[(n, buckets) | n <- [begin,begin+step..end]] 68 | -------------------------------------------------------------------------------- /src/DaemonRunners.hs: -------------------------------------------------------------------------------- 1 | -- 2 | -- Data vault for metrics 3 | -- 4 | -- Copyright © 2013-2014 Anchor Systems, Pty Ltd and Others 5 | -- 6 | -- The code in this file, and the program it is a part of, is 7 | -- made available to you by its authors as open source software: 8 | -- you can redistribute it and/or modify it under the terms of 9 | -- the 3-clause BSD licence. 10 | -- 11 | 12 | {-# LANGUAGE RankNTypes #-} 13 | {-# LANGUAGE TupleSections #-} 14 | 15 | -- 16 | -- | This module encapsulates the various daemons that you might want to start 17 | -- up as part of a Vaultaire cluster, along with their default behaviours. 18 | -- 19 | module DaemonRunners ( 20 | DaemonProcess, 21 | waitDaemon, 22 | forkThread, 23 | forkThreads, 24 | daemonWorker, 25 | daemonProfiler, 26 | runBrokerDaemon, 27 | runWriterDaemon, 28 | runReaderDaemon, 29 | runContentsDaemon 30 | ) where 31 | 32 | import Control.Applicative 33 | import Control.Concurrent.Async 34 | import Control.Concurrent.MVar 35 | import Data.Maybe 36 | import Network.URI 37 | import Pipes 38 | import System.Log.Logger 39 | import System.ZMQ4.Monadic hiding (async) 40 | import qualified System.ZMQ4.Monadic as Z 41 | 42 | import Vaultaire.Broker 43 | import Vaultaire.Contents (startContents) 44 | import Vaultaire.Daemon 45 | import Vaultaire.Profiler 46 | import Vaultaire.Reader (startReader) 47 | import Vaultaire.Util 48 | import Vaultaire.Writer (startWriter) 49 | 50 | 51 | type DaemonProcess a = ( Async a -- worker thread 52 | , Maybe (Async ())) -- profiler thread 53 | 54 | daemonWorker :: DaemonProcess a -> Async a 55 | daemonWorker = fst 56 | 57 | daemonProfiler :: DaemonProcess a -> Maybe (Async ()) 58 | daemonProfiler = snd 59 | 60 | -- | Wait for a worker daemon, and its profiler - if any, to finish. 61 | waitDaemon :: DaemonProcess a -> IO a 62 | waitDaemon (worker, Nothing) = wait worker 63 | waitDaemon (worker, Just prof) = fst <$> waitBoth worker prof 64 | 65 | -- | Fork a worker daemon thread. 66 | forkThread :: IO a -> IO (Async a) 67 | forkThread action = do 68 | a <- async action 69 | link a 70 | return a 71 | 72 | -- | Fork a daemon worker thread and (maybe) a profiler thread associated with it. 73 | forkThreads :: IO a -> Maybe (IO ()) -> IO (DaemonProcess a) 74 | forkThreads action prof = do 75 | a <- async action 76 | link a 77 | b <- maybe (return Nothing) (fmap Just . async) prof 78 | _ <- maybe (return ()) (link2 a) b 79 | 80 | return (a, b) 81 | 82 | linkThreadZMQ :: forall a z. ZMQ z a -> ZMQ z () 83 | linkThreadZMQ a = (liftIO . link) =<< Z.async a 84 | 85 | runBrokerDaemon :: MVar () -> IO (DaemonProcess ()) 86 | runBrokerDaemon end = 87 | flip forkThreads Nothing $ do 88 | infoM "Daemons.runBrokerDaemon" "Broker daemon started" 89 | runZMQ $ do 90 | -- Writer proxy. 91 | linkThreadZMQ $ startProxy 92 | (Router,"tcp://*:5560") (Dealer,"tcp://*:5561") "tcp://*:5000" 93 | 94 | -- Reader proxy. 95 | linkThreadZMQ $ startProxy 96 | (Router,"tcp://*:5570") (Dealer,"tcp://*:5571") "tcp://*:5001" 97 | 98 | -- Contents proxy. 99 | linkThreadZMQ $ startProxy 100 | (Router,"tcp://*:5580") (Dealer,"tcp://*:5581") "tcp://*:5002" 101 | 102 | -- Telemetry proxy. 103 | linkThreadZMQ $ startProxy 104 | (XPub, "tcp://*:6660") (XSub,"tcp://*:6661") "tcp://*:6000" 105 | 106 | readMVar end 107 | 108 | runWorkerDaemon 109 | :: String -- ^ Ceph pool 110 | -> String -- ^ Ceph user 111 | -> String -- ^ Broker URI 112 | -> MVar () -- ^ Shutdown 113 | -> String -- ^ Optional daemon name 114 | -> Maybe (Period,Int) -- ^ Optional profiler (period, channel bound) 115 | -> (DaemonArgs -> IO ()) -- ^ Run this worker daemon 116 | -> IO (DaemonProcess ()) 117 | runWorkerDaemon pool user brok down name prof daemon = do 118 | (args, env) <- daemonArgs (fromMaybe (fatal "runWorkerDaemon" "Invalid broker URI") 119 | (parseURI brok)) 120 | (Just user) pool down 121 | (if name == "" then Nothing else Just name) 122 | (trip profilingPort <$> prof) 123 | forkThreads (daemon args) 124 | (fmap (const $ startProfiler env) prof) 125 | where trip x (y,z) = (x,y,z) 126 | 127 | runWriterDaemon :: String 128 | -> String 129 | -> String 130 | -> BucketSize 131 | -> MVar () 132 | -> String 133 | -> Maybe (Period, Int) 134 | -> IO (DaemonProcess ()) 135 | runWriterDaemon pool user brok rollover down name prof = do 136 | infoM "Daemons.runWriterDaemon" "Writer daemon starting" 137 | runWorkerDaemon pool user ("tcp://" ++ brok ++ ":5561") 138 | down name prof (flip startWriter rollover) 139 | 140 | runReaderDaemon :: String 141 | -> String 142 | -> String 143 | -> MVar () 144 | -> String 145 | -> Maybe (Period, Int) 146 | -> IO (DaemonProcess ()) 147 | runReaderDaemon pool user brok down name prof = do 148 | infoM "Daemons.runReaderDaemon" "Reader daemon starting" 149 | runWorkerDaemon pool user ("tcp://" ++ brok ++ ":5571") 150 | down name prof startReader 151 | 152 | runContentsDaemon :: String 153 | -> String 154 | -> String 155 | -> MVar () 156 | -> String 157 | -> Maybe (Period, Int) 158 | -> IO (DaemonProcess ()) 159 | runContentsDaemon pool user brok down name prof = do 160 | infoM "Daemons.runContentsDaemon" "Contents daemon starting" 161 | runWorkerDaemon pool user ("tcp://" ++ brok ++ ":5581") 162 | down name prof startContents 163 | 164 | -- The other ports are hard-coded here, so we define the profiling port here too. 165 | profilingPort = 6661 166 | -------------------------------------------------------------------------------- /src/DemoWave.hs: -------------------------------------------------------------------------------- 1 | -- 2 | -- Data vault for metrics 3 | -- 4 | -- Copyright © 2013-2014 Anchor Systems, Pty Ltd and Others 5 | -- 6 | -- The code in this file, and the program it is a part of, is 7 | -- made available to you by its authors as open source software: 8 | -- you can redistribute it and/or modify it under the terms of 9 | -- the 3-clause BSD licence. 10 | -- 11 | 12 | {-# LANGUAGE OverloadedStrings #-} 13 | {-# LANGUAGE RecordWildCards #-} 14 | 15 | module Main where 16 | import Control.Concurrent 17 | import Control.Concurrent.Async 18 | import Control.Monad 19 | import Data.Binary.IEEE754 (doubleToWord, wordToDouble) 20 | import qualified Data.ByteString.Char8 as S 21 | import Data.Word 22 | import Options.Applicative 23 | import System.Log.Logger 24 | import Text.Printf 25 | 26 | import Marquise.Client 27 | import Package 28 | import Vaultaire.Program 29 | import Vaultaire.Types 30 | 31 | data Options = Options { 32 | debug :: Bool 33 | } 34 | 35 | -- | Command line option parsing 36 | 37 | helpfulParser :: ParserInfo Options 38 | helpfulParser = info (helper <*> optionsParser) fullDesc 39 | 40 | optionsParser :: Parser Options 41 | optionsParser = 42 | Options <$> parseDebug 43 | where 44 | parseDebug = switch $ 45 | long "debug" 46 | <> short 'd' 47 | <> help "Set log level to DEBUG" 48 | 49 | parseOrigin :: Parser Origin 50 | parseOrigin = argument (fmap mkOrigin str) (metavar "ORIGIN") 51 | where 52 | mkOrigin = Origin . S.pack 53 | 54 | 55 | main :: IO () 56 | main = do 57 | Options{..} <- execParser helpfulParser 58 | 59 | let level = if debug 60 | then Debug 61 | else Normal 62 | 63 | quit <- initializeProgram (package ++ "-" ++ version) level 64 | 65 | logM "Main.main" DEBUG "Starting generator" 66 | 67 | spool <- createSpoolFiles "demowave" 68 | 69 | let a = hashIdentifier "This is a test of the emergency broadcast system" 70 | loop quit spool a 71 | 72 | logM "Main.main" DEBUG "End" 73 | 74 | 75 | loop :: MVar () -> SpoolFiles -> Address -> IO () 76 | loop shutdown spool address = do 77 | i <- getCurrentTimeNanoseconds 78 | let v = demoWaveAt i 79 | let msg = printf "%s\t%d\t% 9.6f" (show address) (unTimeStamp i) (wordToDouble v) 80 | logM "Main.loop" DEBUG msg 81 | queueSimple spool address i v 82 | 83 | a1 <- async (do 84 | readMVar shutdown 85 | return True) 86 | 87 | a2 <- async (do 88 | threadDelay (5 * 1000000) -- every 5 s 89 | return False) 90 | 91 | (_,done) <- waitAny [a1,a2] 92 | unless done $ loop shutdown spool address 93 | 94 | demoWaveAt :: TimeStamp -> Word64 95 | demoWaveAt (TimeStamp x) = 96 | let 97 | period = 3600 * 3 98 | f = 1/period -- instances per second 99 | w = 2 * pi * f :: Double 100 | t = ((/ 1e9) . fromRational . toRational) x 101 | y = sin (w * t) 102 | in 103 | doubleToWord y 104 | 105 | -------------------------------------------------------------------------------- /src/Inspect.hs: -------------------------------------------------------------------------------- 1 | -- 2 | -- Data vault for metrics 3 | -- 4 | -- Copyright © 2013-2014 Anchor Systems, Pty Ltd and Others 5 | -- 6 | -- The code in this file, and the program it is a part of, is 7 | -- made available to you by its authors as open source software: 8 | -- you can redistribute it and/or modify it under the terms of 9 | -- the 3-clause BSD licence. 10 | -- 11 | 12 | {-# LANGUAGE RankNTypes #-} 13 | {-# LANGUAGE RecordWildCards #-} 14 | 15 | module Main where 16 | 17 | import Control.Concurrent.Async 18 | import Control.Concurrent.MVar 19 | import Control.Monad 20 | import qualified Data.ByteString.Char8 as S 21 | import Data.Maybe (fromJust) 22 | import Data.String 23 | import Data.Word (Word64) 24 | import Options.Applicative hiding (Parser, option) 25 | import qualified Options.Applicative as O 26 | import System.Directory 27 | import System.Log.Logger 28 | import Text.Trifecta 29 | 30 | import CommandRunners 31 | import DaemonRunners (forkThread) 32 | import Marquise.Client 33 | import Package (package, version) 34 | import Vaultaire.Program 35 | 36 | 37 | data Options = Options 38 | { pool :: String 39 | , user :: String 40 | , broker :: String 41 | , debug :: Bool 42 | , quiet :: Bool 43 | , component :: Component } 44 | 45 | data Component = 46 | None 47 | | RegisterOrigin { origin :: Origin 48 | , buckets :: Word64 49 | , step :: Word64 50 | , start :: TimeStamp 51 | , end :: TimeStamp } 52 | | Read { origin :: Origin 53 | , address :: Address 54 | , start :: TimeStamp 55 | , end :: TimeStamp } 56 | | List { origin :: Origin } 57 | | DumpDays { origin :: Origin } 58 | 59 | -- | Command line option parsing 60 | 61 | helpfulParser :: Options -> O.ParserInfo Options 62 | helpfulParser os = info (helper <*> optionsParser os) fullDesc 63 | 64 | optionsParser :: Options -> O.Parser Options 65 | optionsParser Options{..} = Options <$> parsePool 66 | <*> parseUser 67 | <*> parseBroker 68 | <*> parseDebug 69 | <*> parseQuiet 70 | <*> parseComponents 71 | where 72 | parsePool = strOption $ 73 | long "pool" 74 | <> short 'p' 75 | <> metavar "POOL" 76 | <> value pool 77 | <> showDefault 78 | <> help "Ceph pool name for storage" 79 | 80 | parseUser = strOption $ 81 | long "user" 82 | <> short 'u' 83 | <> metavar "USER" 84 | <> value user 85 | <> showDefault 86 | <> help "Ceph user for access to storage" 87 | 88 | parseBroker = strOption $ 89 | long "broker" 90 | <> short 'b' 91 | <> metavar "BROKER" 92 | <> value broker 93 | <> showDefault 94 | <> help "Vault broker host name or IP address" 95 | 96 | parseDebug = switch $ 97 | long "debug" 98 | <> short 'd' 99 | <> help "Output lots of debugging information" 100 | 101 | parseQuiet = switch $ 102 | long "quiet" 103 | <> short 'q' 104 | <> help "Only emit warnings or fatal messages" 105 | 106 | parseComponents = subparser 107 | ( parseRegisterOriginComponent 108 | <> parseReadComponent 109 | <> parseListComponent 110 | <> parseDumpDaysComponent ) 111 | 112 | parseRegisterOriginComponent = 113 | componentHelper "register" registerOriginParser "Register a new origin" 114 | 115 | parseReadComponent = 116 | componentHelper "read" readOptionsParser "Read points" 117 | 118 | parseListComponent = 119 | componentHelper "list" listOptionsParser "List addresses and metadata in origin" 120 | 121 | parseDumpDaysComponent = 122 | componentHelper "days" dumpDaysParser "Display the current day map contents" 123 | 124 | componentHelper cmd_name parser desc = 125 | command cmd_name (info (helper <*> parser) (progDesc desc)) 126 | 127 | parseOrigin :: O.Parser Origin 128 | parseOrigin = argument (fmap mkOrigin str) (metavar "ORIGIN") 129 | where 130 | mkOrigin = Origin . S.pack 131 | 132 | readOptionsParser :: O.Parser Component 133 | readOptionsParser = Read <$> parseOrigin 134 | <*> parseAddress 135 | <*> parseStart 136 | <*> parseEnd 137 | where 138 | parseAddress = argument (fmap fromString str) (metavar "ADDRESS") 139 | parseStart = O.option auto $ 140 | long "start" 141 | <> short 's' 142 | <> value 0 143 | <> showDefault 144 | <> help "Start time in nanoseconds since epoch" 145 | 146 | parseEnd = O.option auto $ 147 | long "end" 148 | <> short 'e' 149 | <> value maxBound 150 | <> showDefault 151 | <> help "End time in nanoseconds since epoch" 152 | 153 | listOptionsParser :: O.Parser Component 154 | listOptionsParser = List <$> parseOrigin 155 | 156 | dumpDaysParser :: O.Parser Component 157 | dumpDaysParser = DumpDays <$> parseOrigin 158 | 159 | registerOriginParser :: O.Parser Component 160 | registerOriginParser = RegisterOrigin <$> parseOrigin 161 | <*> parseBuckets 162 | <*> parseStep 163 | <*> parseBegin 164 | <*> parseEnd 165 | where 166 | parseBuckets = O.option auto $ 167 | long "buckets" 168 | <> short 'n' 169 | <> value 128 170 | <> showDefault 171 | <> help "Number of buckets to distribute writes over" 172 | 173 | parseStep = O.option auto $ 174 | long "step" 175 | <> short 's' 176 | <> value 14400000000000 177 | <> showDefault 178 | <> help "Back-dated rollover period (see documentation: TODO)" 179 | 180 | parseBegin = O.option auto $ 181 | long "begin" 182 | <> short 'b' 183 | <> value 0 184 | <> showDefault 185 | <> help "Back-date begin time (default is no backdating)" 186 | 187 | parseEnd = O.option auto $ 188 | long "end" 189 | <> short 'e' 190 | <> value 0 191 | <> showDefault 192 | <> help "Back-date end time" 193 | 194 | -- | Config file parsing 195 | parseConfig :: FilePath -> IO Options 196 | parseConfig fp = do 197 | exists <- doesFileExist fp 198 | if exists 199 | then do 200 | maybe_ls <- parseFromFile configParser fp 201 | case maybe_ls of 202 | Just ls -> return $ mergeConfig ls defaultConfig 203 | Nothing -> error "Failed to parse config" 204 | else return defaultConfig 205 | where 206 | defaultConfig = Options "vaultaire" "vaultaire" "localhost" False False None 207 | mergeConfig ls Options{..} = fromJust $ 208 | Options <$> lookup "pool" ls `mplus` pure pool 209 | <*> lookup "user" ls `mplus` pure user 210 | <*> lookup "broker" ls `mplus` pure broker 211 | <*> pure debug 212 | <*> pure quiet 213 | <*> pure None 214 | 215 | configParser :: Parser [(String, String)] 216 | configParser = some $ liftA2 (,) 217 | (spaces *> possibleKeys <* spaces <* char '=') 218 | (spaces *> (stringLiteral <|> stringLiteral')) 219 | 220 | possibleKeys :: Parser String 221 | possibleKeys = 222 | string "pool" 223 | <|> string "user" 224 | <|> string "broker" 225 | 226 | parseArgsWithConfig :: FilePath -> IO Options 227 | parseArgsWithConfig = parseConfig >=> execParser . helpfulParser 228 | 229 | -- 230 | -- Main program entry point 231 | -- 232 | 233 | main :: IO () 234 | main = do 235 | Options{..} <- parseArgsWithConfig "/etc/vaultaire.conf" 236 | 237 | let level | debug = Debug 238 | | quiet = Quiet 239 | | otherwise = Normal 240 | 241 | quit <- initializeProgram (package ++ "-" ++ version) level 242 | 243 | -- Run selected command. 244 | debugM "Main.main" "Starting command" 245 | 246 | -- Although none of the commands are running in the background, we get off 247 | -- of the main thread so that we can block the main thread on the quit 248 | -- semaphore, such that a user interrupt will kill the program. 249 | 250 | a <- forkThread $ do 251 | case component of 252 | None -> return () 253 | RegisterOrigin origin buckets step begin end -> 254 | runRegisterOrigin pool user origin buckets step begin end 255 | Read{} -> 256 | error "Currently unimplemented. Use marquise's `data read` command" 257 | List _ -> 258 | error "Currently unimplemented. Use marquise's `data list` command" 259 | DumpDays origin -> 260 | runDumpDayMap pool user origin 261 | putMVar quit () 262 | 263 | wait a 264 | debugM "Main.main" "End" 265 | 266 | -------------------------------------------------------------------------------- /src/TelemetryProgram.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | import Control.Exception 4 | import Network.URI 5 | import Options.Applicative 6 | import System.ZMQ4 hiding (shutdown) 7 | 8 | import Vaultaire.Types 9 | 10 | helpfulParser :: ParserInfo String 11 | helpfulParser = info (helper <*> optionsParser) fullDesc 12 | 13 | optionsParser :: Parser String 14 | optionsParser = parseBroker 15 | where 16 | parseBroker = strOption $ 17 | long "broker" 18 | <> short 'b' 19 | <> metavar "BROKER" 20 | <> value "localhost" 21 | <> showDefault 22 | <> help "Vault broker host name or IP address" 23 | 24 | main :: IO () 25 | main = do 26 | broker <- execParser helpfulParser 27 | maybe (putStrLn "Invalid broker URI") 28 | runTelemetrySub 29 | (parseURI $ "tcp://" ++ broker ++ ":6660") 30 | 31 | runTelemetrySub :: URI -> IO () 32 | runTelemetrySub broker = 33 | -- connect to the broker for telemtrics 34 | withContext $ \ctx -> 35 | withSocket ctx Sub $ \sock -> do 36 | connect sock $ show broker 37 | subscribe sock "" 38 | go sock 39 | where go sock = do 40 | x <- receive sock 41 | case (fromWire x :: Either SomeException TeleResp) of 42 | Right y -> print y 43 | _ -> putStrLn "Unrecognised telemetric response." 44 | go sock 45 | -------------------------------------------------------------------------------- /src/Vault.hs: -------------------------------------------------------------------------------- 1 | -- 2 | -- Data vault for metrics 3 | -- 4 | -- Copyright © 2013-2014 Anchor Systems, Pty Ltd and Others 5 | -- 6 | -- The code in this file, and the program it is a part of, is 7 | -- made available to you by its authors as open source software: 8 | -- you can redistribute it and/or modify it under the terms of 9 | -- the 3-clause BSD licence. 10 | -- 11 | 12 | {-# LANGUAGE RankNTypes #-} 13 | {-# LANGUAGE RecordWildCards #-} 14 | 15 | module Main where 16 | 17 | import Control.Monad 18 | import Data.Maybe (fromJust) 19 | import Data.Word (Word64) 20 | import Network.BSD (getHostName) 21 | import Options.Applicative hiding (Parser, option) 22 | import qualified Options.Applicative as O 23 | import System.Directory 24 | import System.Environment 25 | import System.Log.Logger 26 | import Text.Read 27 | import Text.Trifecta 28 | 29 | import DaemonRunners 30 | import Package (package, version) 31 | import Vaultaire.Program 32 | import Vaultaire.Types (agentIDLength) 33 | 34 | data Options = Options 35 | { pool :: String 36 | , user :: String 37 | , broker :: String 38 | , debug :: Bool 39 | , quiet :: Bool 40 | , noprofile :: Bool 41 | , period :: Int 42 | , bound :: Int 43 | , name :: String 44 | , keyring :: String 45 | , component :: Component } 46 | 47 | data Component = Broker 48 | | Reader 49 | | Writer { bucketSize :: Word64 } 50 | | Contents 51 | 52 | -- | Command line option parsing 53 | 54 | helpfulParser :: Options -> O.ParserInfo Options 55 | helpfulParser os = info (helper <*> optionsParser os) fullDesc 56 | 57 | optionsParser :: Options -> O.Parser Options 58 | optionsParser Options{..} = Options <$> parsePool 59 | <*> parseUser 60 | <*> parseBroker 61 | <*> parseDebug 62 | <*> parseQuiet 63 | <*> parseNoprofile 64 | <*> parsePeriod 65 | <*> parseBound 66 | <*> parseName 67 | <*> parseKeyring 68 | <*> parseComponents 69 | where 70 | parsePool = strOption $ 71 | long "pool" 72 | <> short 'p' 73 | <> metavar "POOL" 74 | <> value pool 75 | <> showDefault 76 | <> help "Ceph pool name for storage" 77 | 78 | parseUser = strOption $ 79 | long "user" 80 | <> short 'u' 81 | <> metavar "USER" 82 | <> value user 83 | <> showDefault 84 | <> help "Ceph user for access to storage" 85 | 86 | parseBroker = strOption $ 87 | long "broker" 88 | <> short 'b' 89 | <> metavar "BROKER" 90 | <> value broker 91 | <> showDefault 92 | <> help "Vault broker host name or IP address" 93 | 94 | parseDebug = switch $ 95 | long "debug" 96 | <> short 'd' 97 | <> help "Output lots of debugging information" 98 | 99 | parseQuiet = switch $ 100 | long "quiet" 101 | <> short 'q' 102 | <> help "Only emit warnings or fatal messages" 103 | 104 | parseNoprofile = switch $ 105 | long "no-profiling" 106 | <> help "Disables profiling" 107 | 108 | parsePeriod = O.option auto $ 109 | long "period" 110 | <> metavar "PERIOD" 111 | <> value period 112 | <> showDefault 113 | <> help "How often the profiler reports telemetric data, in milliseconds." 114 | 115 | parseBound = O.option auto $ 116 | long "bound" 117 | <> metavar "BOUND" 118 | <> value bound 119 | <> showDefault 120 | <> help "How many stat reports the profiler can handle per period before it starts losing accuracy." 121 | 122 | parseName = strOption $ 123 | long "name" 124 | <> short 'n' 125 | <> metavar "NAME" 126 | <> value name 127 | <> showDefault 128 | <> help "Identifiable name for the daemon used for telemetry messages." 129 | 130 | parseKeyring = strOption $ 131 | long "keyring" 132 | <> short 'k' 133 | <> metavar "KEYRING" 134 | <> value "" 135 | <> help "Path to Ceph keyring file. If set, this will override the CEPH_KEYRING environment variable." 136 | 137 | parseComponents = subparser 138 | ( parseBrokerComponent 139 | <> parseReaderComponent 140 | <> parseWriterComponent 141 | <> parseContentsComponent ) 142 | 143 | parseBrokerComponent = 144 | componentHelper "broker" (pure Broker) "Start a broker daemon" 145 | 146 | parseReaderComponent = 147 | componentHelper "reader" (pure Reader) "Start a reader daemon" 148 | 149 | parseWriterComponent = 150 | componentHelper "writer" writerOptionsParser "Start a writer daemon" 151 | 152 | parseContentsComponent = 153 | componentHelper "contents" (pure Contents) "Start a contents daemon" 154 | 155 | componentHelper cmd_name parser desc = 156 | command cmd_name (info (helper <*> parser) (progDesc desc)) 157 | 158 | 159 | writerOptionsParser :: O.Parser Component 160 | writerOptionsParser = Writer <$> parseBucketSize 161 | where 162 | parseBucketSize = O.option auto $ 163 | long "roll_over_size" 164 | <> short 'r' 165 | <> value 4194304 166 | <> showDefault 167 | <> help "Maximum bytes in any given bucket before rollover" 168 | 169 | -- | Config file parsing 170 | parseConfig :: FilePath -> IO Options 171 | parseConfig fp = do 172 | exists <- doesFileExist fp 173 | defaults <- liftM defaultConfig defaultAgentID 174 | if exists 175 | then do 176 | maybe_ls <- parseFromFile configParser fp 177 | case maybe_ls of 178 | Just ls -> return $ mergeConfig ls defaults 179 | Nothing -> error "Failed to parse config" 180 | else return defaults 181 | where 182 | defaultConfig host = 183 | Options "vaultaire" -- Use 'vaultaire' rados pool. 184 | "vaultaire" -- Connect as 'vaultaire' user. 185 | "localhost" -- Default to broker on localhost. 186 | False -- Don't print debug output. 187 | False -- Don't suppress all output. 188 | False -- Don't disable profiling. 189 | 1000 -- Write telemetry every 1000ms. 190 | 2048 -- Handle <= 2048 telemetry reports per period. 191 | host -- Use our hostname for telemetry agent ID. 192 | "" -- Don't set CEPH_KEYRING. 193 | Broker -- Run in broker mode. 194 | 195 | mergeConfig ls Options{..} = fromJust $ 196 | Options <$> lookup "pool" ls `mplus` pure pool 197 | <*> lookup "user" ls `mplus` pure user 198 | <*> lookup "broker" ls `mplus` pure broker 199 | <*> pure debug 200 | <*> pure quiet 201 | <*> pure noprofile 202 | <*> join (readMaybe <$> lookup "period" ls) `mplus` pure period 203 | <*> join (readMaybe <$> lookup "bound" ls) `mplus` pure period 204 | <*> lookup "name" ls `mplus` pure name 205 | <*> lookup "keyring" ls `mplus` pure keyring 206 | <*> pure Broker 207 | 208 | -- | Construct a sensible default agent ID - the machine's hostname, 209 | -- truncated to the max agent ID length. 210 | defaultAgentID = fmap (take agentIDLength) getHostName 211 | 212 | configParser :: Parser [(String, String)] 213 | configParser = some $ liftA2 (,) 214 | (spaces *> possibleKeys <* spaces <* char '=') 215 | (spaces *> (stringLiteral <|> stringLiteral')) 216 | 217 | possibleKeys :: Parser String 218 | possibleKeys = 219 | string "pool" 220 | <|> string "user" 221 | <|> string "broker" 222 | 223 | parseArgsWithConfig :: FilePath -> IO Options 224 | parseArgsWithConfig = parseConfig >=> execParser . helpfulParser 225 | 226 | -- If set, override CEPH_KEYRING envvar (used by librados). 227 | updateCephKeyring :: String -> IO () 228 | updateCephKeyring "" = return () 229 | updateCephKeyring k = setEnv "CEPH_KEYRING" k 230 | 231 | -- 232 | -- Main program entry point 233 | -- 234 | 235 | main :: IO () 236 | main = do 237 | Options{..} <- parseArgsWithConfig "/etc/vaultaire.conf" 238 | 239 | let level | debug = Debug 240 | | quiet = Quiet 241 | | otherwise = Normal 242 | 243 | updateCephKeyring keyring 244 | 245 | quit <- initializeProgram (package ++ "-" ++ version) level 246 | 247 | -- Run daemon(s, at present just one). These are all expected to fork 248 | -- threads and return the Async representing them. If they wish to 249 | -- requeust termination they have to put unit into the shutdown MVar and 250 | -- then return; they need to finish up and return if something else puts 251 | -- unit into the MVar. 252 | 253 | debugM "Main.main" "Starting component" 254 | 255 | a <- case component of 256 | Broker -> 257 | runBrokerDaemon quit 258 | 259 | Reader -> 260 | if noprofile 261 | then runReaderDaemon pool user broker quit name Nothing 262 | else runReaderDaemon pool user broker quit name (Just (period,bound)) 263 | 264 | Writer roll_over_size -> 265 | if noprofile 266 | then runWriterDaemon pool user broker roll_over_size quit name Nothing 267 | else runWriterDaemon pool user broker roll_over_size quit name (Just (period,bound)) 268 | 269 | Contents -> 270 | if noprofile 271 | then runContentsDaemon pool user broker quit name Nothing 272 | else runContentsDaemon pool user broker quit name (Just (period,bound)) 273 | 274 | -- Block until shutdown triggered 275 | debugM "Main.main" "Running until shutdown" 276 | _ <- waitDaemon a 277 | debugM "Main.main" "End" 278 | -------------------------------------------------------------------------------- /tests/ContentsTest.hs: -------------------------------------------------------------------------------- 1 | -- 2 | -- Data vault for metrics 3 | -- 4 | -- Copyright © 2013-2014 Anchor Systems, Pty Ltd and Others 5 | -- 6 | -- The code in this file, and the program it is a part of, is 7 | -- made available to you by its authors as open source software: 8 | -- you can redistribute it and/or modify it under the terms of 9 | -- the 3-clause BSD licence. 10 | -- 11 | 12 | {-# LANGUAGE GADTs #-} 13 | {-# LANGUAGE OverloadedStrings #-} 14 | {-# OPTIONS -fno-warn-type-defaults #-} 15 | 16 | module Main where 17 | 18 | import System.ZMQ4.Monadic 19 | 20 | import Test.Hspec hiding (pending) 21 | 22 | import Control.Concurrent 23 | import Data.HashMap.Strict (fromList) 24 | import Data.Maybe 25 | import Data.String 26 | import Data.Text 27 | import Network.URI 28 | import Pipes.Prelude (toListM) 29 | import Test.Hspec.QuickCheck 30 | import Test.QuickCheck 31 | import Test.QuickCheck.Monadic (assert, monadicIO, run) 32 | 33 | import Marquise.Client 34 | import TestHelpers 35 | import Vaultaire.Broker 36 | import Vaultaire.Contents 37 | import Vaultaire.Daemon 38 | import Vaultaire.Util 39 | 40 | startDaemons :: IO () 41 | startDaemons = do 42 | quit <- newEmptyMVar 43 | linkThread $ do 44 | runZMQ $ startProxy (Router,"tcp://*:5580") 45 | (Dealer,"tcp://*:5581") "tcp://*:5008" 46 | readMVar quit 47 | 48 | args <- daemonArgsDefault (fromJust $ parseURI "tcp://localhost:5581") 49 | Nothing "test" quit 50 | linkThread $ startContents args 51 | 52 | main :: IO () 53 | main = do 54 | startDaemons 55 | hspec suite 56 | 57 | suite :: Spec 58 | suite = do 59 | -- TODO: This does not belong here, move to another test at the least. 60 | -- The reason for encodeAddressToString and decodeStringAsAddress beyond 61 | -- Show and IsString is questionable. Is this made use of anywhere? Perhaps 62 | -- we can remove it before we have to maintain it. 63 | describe "Addresses" $ do 64 | it "encodes an address in base62" $ do 65 | show (0 :: Address) `shouldBe` "00000000000" 66 | show (2^64-1 :: Address) `shouldBe` "LygHa16AHYF" 67 | show (minBound :: Address) `shouldBe` "00000000000" 68 | show (maxBound :: Address) `shouldBe` "LygHa16AHYF" 69 | 70 | it "decodes an address from base62" $ do 71 | fromString "00000000000" `shouldBe` (0 :: Address) 72 | fromString "00000000001" `shouldBe` (1 :: Address) 73 | fromString "LygHa16AHYF" `shouldBe` ((2^64-1) :: Address) 74 | fromString "LygHa16AHYG" `shouldBe` (0 :: Address) 75 | 76 | describe "Full stack" $ do 77 | it "unions two dicts" $ do 78 | let dict_a = listToDict [("a", "1")] 79 | let dict_b = listToDict [("a", "2")] 80 | let addr = 1 81 | 82 | cleanupTestEnvironment 83 | 84 | let o = Origin "PONY" 85 | xs <- withContentsConnection "localhost" $ \c -> do 86 | updateSourceDict addr dict_a o c 87 | updateSourceDict addr dict_b o c 88 | toListM (enumerateOrigin o c) 89 | case xs of 90 | [(addr', dict)] -> do 91 | dict `shouldBe` dict_b 92 | addr' `shouldBe` addr 93 | _ -> error "expected one" 94 | 95 | prop "updates source dict for any address" propSourceDictUpdated 96 | 97 | 98 | listToDict :: [(Text, Text)] -> SourceDict 99 | listToDict elts = either error id . makeSourceDict $ fromList elts 100 | 101 | propSourceDictUpdated :: Address -> SourceDict -> Property 102 | propSourceDictUpdated addr dict = monadicIO $ do 103 | xs <- run $ do 104 | -- Clear out ceph 105 | cleanupTestEnvironment 106 | let o = Origin "PONY" 107 | withContentsConnection "localhost" $ \c -> do 108 | updateSourceDict addr dict o c 109 | toListM (enumerateOrigin o c) 110 | case xs of 111 | [(addr', dict')] -> assert (addr' == addr && dict' == dict) 112 | _ -> error "expected one" 113 | -------------------------------------------------------------------------------- /tests/DaemonTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Main where 4 | 5 | import Control.Applicative 6 | import Control.Concurrent.MVar 7 | import Data.ByteString (ByteString) 8 | import qualified Data.ByteString as S 9 | import Data.List.NonEmpty (fromList) 10 | import Data.Maybe 11 | import Network.URI 12 | import System.Rados.Monadic hiding (async) 13 | import System.ZMQ4.Monadic hiding (async) 14 | import Test.Hspec 15 | 16 | import TestHelpers 17 | import Vaultaire.Broker 18 | import Vaultaire.Daemon hiding (async) 19 | import Vaultaire.DayMap 20 | import Vaultaire.RollOver 21 | import Vaultaire.Types 22 | import Vaultaire.Util 23 | 24 | 25 | main :: IO () 26 | main = do 27 | linkThread $ runZMQ $ startProxy 28 | (Router,"tcp://*:5560") (Dealer,"tcp://*:5561") "tcp://*:5000" 29 | 30 | hspec suite 31 | 32 | -- | A pre-requisite for this test suite is a connection to a test ceph cluster 33 | -- with a "test" pool. 34 | suite :: Spec 35 | suite = do 36 | describe "Daemon messaging" $ do 37 | it "starts up and shuts down cleanly" $ 38 | runTestDaemon "tcp://localhost:1234" (return ()) 39 | >>= (`shouldBe` ()) 40 | 41 | it "ignores bad message and replies to good message" $ 42 | withReplier $ do 43 | sendBadMsg 44 | sendPonyMsg >>= (`shouldBe` ["PONYim in ur vaults"]) 45 | 46 | it "replies to mutliple messages" $ 47 | withReplier $ do 48 | sendPonyMsg >>= (`shouldBe` ["PONYim in ur vaults"]) 49 | sendPonyMsg >>= (`shouldBe` ["PONYim in ur vaults"]) 50 | 51 | describe "Daemon day map" $ do 52 | it "loads an origins map" $ do 53 | (simple,ext) <- runTestDaemon "tcp://localhost:1234" $ 54 | (,) <$> withSimpleDayMap "PONY" (lookupFirst 42) 55 | <*> withExtendedDayMap "PONY" (lookupFirst 42) 56 | 57 | (,) <$> simple <*> ext `shouldBe` Just ((0, 8), (0,15)) 58 | 59 | it "does not invalidate cache on same filesize" $ do 60 | result <- runTestDaemon "tcp://localhost:1234" $ do 61 | writePonyDayMap "02_PONY_simple_days" dayFileB 62 | writePonyDayMap "02_PONY_extended_days" dayFileA 63 | refreshOriginDays "PONY" 64 | withSimpleDayMap "PONY" (lookupFirst 42) 65 | 66 | result `shouldBe` Just (0, 8) 67 | 68 | it "does invalidate cache on different filesize" $ do 69 | result <- runTestDaemon "tcp://localhost:1234" $ do 70 | writePonyDayMap "02_PONY_simple_days" dayFileC 71 | refreshOriginDays "PONY" 72 | withSimpleDayMap "PONY" (lookupFirst 300) 73 | 74 | result `shouldBe` Just (255, 254) 75 | 76 | result' <- runTestDaemon "tcp://localhost:1234" $ do 77 | writePonyDayMap "02_PONY_extended_days" dayFileC 78 | refreshOriginDays "PONY" 79 | withExtendedDayMap "PONY" (lookupFirst 300) 80 | 81 | result' `shouldBe` Just (255, 254) 82 | 83 | 84 | describe "Daemon updateSimpleLatest" $ do 85 | it "does not clobber higher value" $ do 86 | new <- runTestDaemon "tcp://localhost:1234" $ do 87 | updateSimpleLatest "PONY" 0x41 88 | liftPool $ runObject "02_PONY_simple_latest" readFull 89 | new `shouldBe` Right "\x42\x00\x00\x00\x00\x00\x00\x00" 90 | 91 | it "does overwrite lower value" $ do 92 | new <- runTestDaemon "tcp://localhost:1234" $ do 93 | cleanup 94 | updateSimpleLatest "PONY" 0x43 95 | liftPool $ runObject "02_PONY_simple_latest" readFull 96 | new `shouldBe` Right "\x43\x00\x00\x00\x00\x00\x00\x00" 97 | 98 | describe "Daemon rollover" $ do 99 | it "correctly rolls over day" $ do 100 | new <- runTestDaemon "tcp://localhost:1234" $ do 101 | updateSimpleLatest "PONY" 0x42 102 | rollOverSimpleDay "PONY" 8 103 | liftPool $ runObject "02_PONY_simple_days" readFull 104 | new `shouldBe` Right dayFileD 105 | 106 | it "does not rollover if the day map has been touched" $ do 107 | new <- runTestDaemon "tcp://localhost:1234" $ do 108 | writePonyDayMap "02_PONY_simple_days" dayFileC 109 | 110 | updateSimpleLatest "PONY" 0x48 111 | rollOverSimpleDay "PONY" 8 112 | 113 | liftPool $ runObject "02_PONY_simple_days" readFull 114 | new `shouldBe` Right dayFileC 115 | 116 | it "does basic sanity checking on latest file" $ 117 | runTestDaemon "tcp://localhost:1234" 118 | (do _ <- liftPool $ runObject "02_PONY_simple_latest" $ 119 | append "garbage" 120 | rollOverSimpleDay "PONY" 8) 121 | `shouldThrow` anyErrorCall 122 | 123 | withReplier :: IO a -> IO a 124 | withReplier f = do 125 | shutdown <- newEmptyMVar 126 | args <- daemonArgsDefault (fromJust $ parseURI "tcp://localhost:5561") 127 | Nothing "test" shutdown 128 | linkThread $ handleMessages args handler 129 | r <- f 130 | putMVar shutdown () 131 | return r 132 | where 133 | handler (Message rep_f (Origin origin) msg ) = 134 | rep_f . PassThrough $ origin `S.append` msg 135 | 136 | 137 | sendPonyMsg :: IO [ByteString] 138 | sendPonyMsg = runZMQ $ do 139 | s <- socket Dealer 140 | connect s "tcp://localhost:5560" 141 | -- Simulate a client sending a sequence number and message 142 | sendMulti s $ fromList ["PONY", "im in ur vaults"] 143 | receiveMulti s 144 | 145 | sendBadMsg :: IO () 146 | sendBadMsg = runZMQ $ do 147 | s <- socket Dealer 148 | connect s "tcp://localhost:5560" 149 | sendMulti s $ fromList ["beep"] 150 | -------------------------------------------------------------------------------- /tests/DayMapTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Main where 4 | 5 | import Data.ByteString 6 | import qualified Data.Map as Map 7 | import Test.Hspec 8 | import Vaultaire.DayMap 9 | 10 | main :: IO () 11 | main = hspec suite 12 | 13 | 14 | goodDayFile, badDayFile,nonZeroDayFile :: ByteString 15 | goodDayMap :: DayMap 16 | 17 | badDayFile = "wat?" 18 | 19 | nonZeroDayFile = "AAAAAAAABBBBBBBB" 20 | 21 | goodDayFile = "\x00\x00\x00\x00\x00\x00\x00\x00\ 22 | \\x01\x00\x00\x00\x00\x00\x00\x00\&\ 23 | \CCCCCCCCDDDDDDDD" 24 | 25 | goodDayMap = DayMap $ Map.fromList [(0,1) 26 | ,(0x4343434343434343, 0x4444444444444444)] 27 | 28 | 29 | simple :: DayMap 30 | simple = DayMap $ Map.fromList [(0, 100), (10, 200), (30, 300)] 31 | 32 | singleEntry :: DayMap 33 | singleEntry = DayMap $ Map.fromList [(0, 100)] 34 | 35 | empty :: DayMap 36 | empty = DayMap Map.empty 37 | 38 | suite :: Spec 39 | suite = do 40 | describe "loading" $ do 41 | it "succeeds with good file" $ 42 | loadDayMap goodDayFile `shouldBe` Right goodDayMap 43 | 44 | it "fails with bad file" $ 45 | loadDayMap badDayFile `shouldBe` Left "corrupt contents,\ 46 | \ should be multiple of 16, was: 4 bytes." 47 | 48 | it "fails with empty file" $ 49 | loadDayMap "" `shouldBe` Left "empty" 50 | 51 | it "fails with non zero start" $ 52 | loadDayMap nonZeroDayFile `shouldBe` Left "bad first entry, \ 53 | \must start at zero." 54 | 55 | describe "lookup" $ do 56 | it "handles left boundary correctly" $ 57 | lookupFirst 0 simple `shouldBe` (0, 100) 58 | 59 | it "handles right boundary correcly" $ 60 | lookupFirst 10 simple `shouldBe` (0, 100) 61 | 62 | it "handles beyond right boundary correcly" $ 63 | lookupFirst 11 simple `shouldBe` (10, 200) 64 | 65 | it "handles beyond end" $ 66 | lookupFirst 31 simple `shouldBe` (30, 300) 67 | 68 | it "handle single entry" $ 69 | lookupFirst 50 singleEntry `shouldBe` (0, 100) 70 | 71 | it "returns ranges" $ do 72 | lookupRange 0 1 simple `shouldBe` [(0, 100)] 73 | lookupRange 3 10 simple `shouldBe` [(0, 100)] 74 | lookupRange 0 11 simple `shouldBe` [(0, 100), (10, 200)] 75 | lookupRange 3 11 simple `shouldBe` [(0, 100), (10, 200)] 76 | -------------------------------------------------------------------------------- /tests/IntegrationTest.hs: -------------------------------------------------------------------------------- 1 | -- 2 | -- Data vault for metrics 3 | -- 4 | -- Copyright © 2013-2014 Anchor Systems, Pty Ltd and Others 5 | -- 6 | -- The code in this file, and the program it is a part of, is 7 | -- made available to you by its authors as open source software: 8 | -- you can redistribute it and/or modify it under the terms of 9 | -- the 3-clause BSD licence. 10 | -- 11 | 12 | {-# LANGUAGE GADTs #-} 13 | {-# LANGUAGE OverloadedStrings #-} 14 | {-# OPTIONS -fno-warn-type-defaults #-} 15 | 16 | module Main where 17 | 18 | 19 | import Control.Concurrent 20 | import Control.Concurrent.Async 21 | import Data.HashMap.Strict (fromList) 22 | import Data.Maybe 23 | import Data.Text 24 | import Network.URI 25 | import Pipes 26 | import qualified Pipes.Prelude as P 27 | import System.Directory 28 | import System.IO 29 | import Test.Hspec hiding (pending) 30 | 31 | import CommandRunners 32 | import DaemonRunners 33 | import Marquise.Client 34 | import Marquise.Server 35 | import TestHelpers (cleanup, daemonArgsTest) 36 | import Vaultaire.Daemon hiding (broker, shutdown) 37 | 38 | pool :: String 39 | pool = "test" 40 | 41 | user :: String 42 | user = "vaultaire" 43 | 44 | destroyExistingVault :: IO () 45 | destroyExistingVault = do 46 | args <- daemonArgsTest (fromJust $ parseURI "inproc://1") 47 | (Just user) pool 48 | runDaemon args cleanup 49 | 50 | startServerDaemons :: FilePath -> MVar () -> IO () 51 | startServerDaemons tmp shutdown = 52 | let 53 | broker = "localhost" 54 | bucket_size = 4194304 55 | num_buckets = 128 56 | step_size = 1440 * 1000000000 57 | origin = Origin "ZZZZZZ" 58 | namespace = "integration" 59 | in do 60 | a1 <- runBrokerDaemon shutdown 61 | a2 <- runWriterDaemon pool user broker bucket_size shutdown "" Nothing 62 | a3 <- runReaderDaemon pool user broker shutdown "" Nothing 63 | a4 <- runContentsDaemon pool user broker shutdown "" Nothing 64 | a5 <- runMarquiseDaemon broker origin namespace shutdown tmp 60 65 | -- link the following threads to this main thread 66 | mapM_ link [ daemonWorker a1 67 | , daemonWorker a2 68 | , daemonWorker a3 69 | , daemonWorker a4 70 | , a5 ] 71 | runRegisterOrigin pool user origin num_buckets step_size 0 0 72 | 73 | setupClientSide :: IO SpoolFiles 74 | setupClientSide = createSpoolFiles "integration" 75 | 76 | -- 77 | -- Sadly, the smazing standard library lacks a standardized way to create a 78 | -- temporary file. You'll need to remove this file when it's done. 79 | -- 80 | 81 | createTempFile :: IO FilePath 82 | createTempFile = do 83 | (name,h) <- openTempFile "." "cache_file-.tmp" 84 | hClose h 85 | return name 86 | 87 | main :: IO () 88 | main = do 89 | quit <- newEmptyMVar 90 | 91 | destroyExistingVault 92 | tmp <- createTempFile 93 | startServerDaemons tmp quit 94 | 95 | spool <- setupClientSide 96 | 97 | hspec (suite spool) 98 | 99 | putMVar quit () 100 | removeFile tmp 101 | 102 | 103 | suite :: SpoolFiles -> Spec 104 | suite spool = 105 | let 106 | origin = Origin "ZZZZZZ" 107 | address = hashIdentifier "Row row row yer boat" 108 | begin = 1406078299651575183 109 | end = 1406078299651575183 110 | timestamp = 1406078299651575183 111 | payload = 42 112 | in do 113 | describe "Generate data" $ 114 | it "sends point via marquise" $ do 115 | queueSimple spool address timestamp payload 116 | flush spool 117 | pass 118 | 119 | describe "Retreive data" $ 120 | it "reads point via marquise" $ 121 | let 122 | go n = do 123 | result <- withReaderConnection "localhost" $ \c -> 124 | P.head (readSimple address begin end origin c >-> decodeSimple) 125 | 126 | case result of 127 | Nothing -> if n > 100 128 | then expectationFailure "Expected a value back, didn't get one" 129 | else do 130 | threadDelay 10000 -- 10 ms 131 | go (n+1) 132 | Just v -> simplePayload v `shouldBe` payload 133 | in 134 | go 1 135 | 136 | 137 | -- | Mark that we are expecting this code to have succeeded, unless it threw an exception 138 | pass :: Expectation 139 | pass = return () 140 | 141 | listToDict :: [(Text, Text)] -> SourceDict 142 | listToDict elts = either error id . makeSourceDict $ fromList elts 143 | -------------------------------------------------------------------------------- /tests/InternalStoreTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE TupleSections #-} 4 | {-# OPTIONS_GHC -fno-warn-orphans #-} 5 | 6 | module Main where 7 | 8 | import Control.Monad 9 | import Control.Monad.State.Strict 10 | import Data.ByteString (ByteString, pack) 11 | import Pipes.Parse 12 | import Test.Hspec 13 | import Test.Hspec.QuickCheck 14 | import Test.QuickCheck 15 | import Test.QuickCheck.Monadic (assert, monadicIO, run) 16 | import TestHelpers 17 | import Vaultaire.Daemon 18 | import Vaultaire.InternalStore (enumerateOrigin, internalStoreBuckets, 19 | readFrom, writeTo) 20 | import Vaultaire.Types 21 | 22 | instance Arbitrary ByteString where arbitrary = fmap pack arbitrary 23 | 24 | rollOverAddress :: Address 25 | rollOverAddress = Address internalStoreBuckets 26 | 27 | main :: IO () 28 | main = hspec suite 29 | 30 | suite :: Spec 31 | suite = do 32 | describe "writing" $ do 33 | it "writes simple bucket correctly" $ do 34 | runTestDaemon "tcp://localhost:1234" $ writeTo (Origin "PONY") 4 "Hai" 35 | readObject "02_PONY_INTERNAL_00000000000000000004_00000000000000000000_simple" 36 | >>= (`shouldBe` Right "\x04\x00\x00\x00\x00\x00\x00\x00\ 37 | \\x00\x00\x00\x00\x00\x00\x00\x00\ 38 | \\x00\x00\x00\x00\x00\x00\x00\x00") 39 | 40 | it "writes extended bucket correctly" $ do 41 | runTestDaemon "tcp://localhost:1234" $ writeTo (Origin "PONY") 4 "Hai" 42 | readObject "02_PONY_INTERNAL_00000000000000000004_00000000000000000000_extended" 43 | >>= (`shouldBe` Right "\x03\x00\x00\x00\x00\x00\x00\x00\&Hai") 44 | 45 | describe "reading" $ do 46 | it "reads a write" $ -- Use the same write, as we have already shown it correct 47 | runTestDaemon "tcp://localhost:1234" 48 | (do writeTo (Origin "PONY") 4 "Hai" 49 | readFrom (Origin "PONY") 4) 50 | >>= (`shouldBe` Just "Hai") 51 | 52 | it "disambiguates collision" $ 53 | runTestDaemon "tcp://localhost:1234" 54 | (do writeTo (Origin "PONY") rollOverAddress "Hai1" 55 | readFrom (Origin "PONY") 0) 56 | >>= (`shouldBe` Nothing) 57 | 58 | describe "enumeration" $ 59 | it "enumerates two writes" $ do 60 | addrs <- runTestDaemon "tcp://localhost:1234" $ do 61 | writeTo (Origin "PONY") rollOverAddress "Hai1" 62 | writeTo (Origin "PONY") 0 "Hai2" 63 | writeTo (Origin "PONY") rollOverAddress "Hai3" -- overwrite 64 | 65 | evalStateT drawAll (enumerateOrigin "PONY") 66 | addrs `shouldBe` [(0, "Hai2"), (rollOverAddress, "Hai3")] 67 | 68 | describe "identity QuickCheck" $ 69 | prop "writes then reads" propWriteThenRead 70 | 71 | propWriteThenRead :: (Origin, Address, ByteString) -> Property 72 | propWriteThenRead arb@(_,_,payload) = monadicIO $ do 73 | (enumeration, read') <- run $ runTestDaemon "tcp://localhost:1234" $ writeThenRead arb 74 | assert $ (enumeration == read') && (read' == payload) 75 | 76 | writeThenRead :: (Origin, Address, ByteString) -> Daemon (ByteString, ByteString) 77 | writeThenRead (o,a,p) = do 78 | writeTo o a p 79 | [(a', e)] <- evalStateT drawAll (enumerateOrigin o) 80 | unless (a' == a) $ error "invalid address from enumeration" 81 | r <- readFrom o a >>= maybe (error "no value") return 82 | return (e,r) 83 | -------------------------------------------------------------------------------- /tests/ProfilerTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | import Control.Applicative 4 | import Control.Concurrent 5 | import Control.Concurrent.Async 6 | import Control.Exception 7 | import Control.Monad 8 | import Control.Monad.Reader 9 | import Control.Monad.Trans.State 10 | import qualified Data.List as L 11 | import Data.Maybe 12 | import Network.URI 13 | import System.ZMQ4 hiding (shutdown) 14 | import qualified System.ZMQ4.Monadic as Z 15 | import Test.Hspec hiding (pending) 16 | 17 | import TestHelpers 18 | import Vaultaire.Broker 19 | import Vaultaire.Daemon 20 | import Vaultaire.Profiler 21 | import Vaultaire.Types 22 | import Vaultaire.Util 23 | import Vaultaire.Writer 24 | 25 | main :: IO () 26 | main = hspec suite 27 | 28 | suite :: Spec 29 | suite = 30 | describe "Requests" $ 31 | it "have corresponding telemetric data" $ do 32 | runTestDaemon "tcp://localhost:1234" loadState 33 | sig <- newEmptyMVar 34 | client <- testTelemetry 35 | _ <- testWriter sig writeThings 36 | putMVar sig () 37 | x <- wait client 38 | x `shouldBe` expected 39 | 40 | 41 | expected :: [TeleMsgType] 42 | expected = [ WriterSimplePoints 43 | , WriterExtendedPoints 44 | , WriterRequest 45 | , WriterRequestLatency 46 | , WriterCephLatency ] 47 | 48 | testTelemetry :: IO (Async [TeleMsgType]) 49 | testTelemetry = async $ do 50 | -- setup a broker for telemetry 51 | linkThread $ 52 | Z.runZMQ $ startProxy (XPub,"tcp://*:6660") 53 | (XSub,"tcp://*:6661") 54 | "tcp://*:6000" 55 | 56 | -- connect to the broker for telemtrics 57 | withContext $ \ctx -> 58 | withSocket ctx Sub $ \sock -> do 59 | connect sock "tcp://localhost:6660" 60 | subscribe sock "" 61 | L.nub <$> L.sort <$> execStateT (forM expected $ const $ go sock) [] 62 | where go sock = do 63 | x <- liftIO $ receive sock 64 | case (fromWire x :: Either SomeException TeleResp) of 65 | Right y -> liftIO (print y) >> modify ((_type $ _msg y):) 66 | _ -> error "Unrecognised telemetric response" 67 | 68 | testWriter :: MVar () -> IO () -> IO (Async (), Async ()) 69 | testWriter quit act = do 70 | -- setup a broker so we can "send" to this testWriter daemon 71 | linkThread $ 72 | Z.runZMQ $ startProxy (Router,"tcp://*:5560") 73 | (Dealer,"tcp://*:5561") 74 | "tcp://*:5000" 75 | 76 | -- start the testWriter daemon and its profiler 77 | (args, prof) <- daemonArgs (fromJust $ parseURI "tcp://localhost:5561") 78 | Nothing "test" quit 79 | (Just "writer-test") (Just (6661, 1000, 2048)) 80 | w <- async $ startWriter args 0 81 | p <- async $ startProfiler prof 82 | 83 | -- perform the fake "send" actions 84 | _ <- act 85 | return (w,p) 86 | 87 | writeThings :: IO () 88 | writeThings = forM_ ([0..100]::[Int]) $ const sendTestMsg 89 | -------------------------------------------------------------------------------- /tests/ReaderAlgorithms.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# OPTIONS_GHC -fno-warn-orphans #-} 6 | 7 | module Main where 8 | 9 | import Control.Applicative 10 | import Control.Monad.Primitive 11 | import Control.Monad.ST 12 | import Data.ByteString (ByteString) 13 | import qualified Data.Vector.Algorithms.Merge as M 14 | import Data.Vector.Generic.Mutable (MVector) 15 | import Data.Vector.Storable (Vector) 16 | import qualified Data.Vector.Storable as V 17 | import Data.Vector.Storable.ByteString 18 | import Test.Hspec 19 | import Test.Hspec.QuickCheck 20 | import Test.QuickCheck.Arbitrary 21 | import Test.QuickCheck.Gen 22 | import Vaultaire.ReaderAlgorithms (Point (..)) 23 | import qualified Vaultaire.ReaderAlgorithms as A 24 | import Vaultaire.Types 25 | 26 | data AddrStartEnd = AddrStartEnd Address TimeStamp TimeStamp 27 | deriving Show 28 | 29 | instance Arbitrary AddrStartEnd where 30 | arbitrary = do 31 | addr <- Address <$> elements [0..9] 32 | start <- div 2 <$> arbitrary `suchThat` (> 0) 33 | end <- arbitrary `suchThat` (> start) 34 | return $ AddrStartEnd addr start end 35 | 36 | 37 | instance Arbitrary (Vector Point) where 38 | arbitrary = V.fromList <$> arbitrary 39 | 40 | instance Arbitrary Point where 41 | arbitrary = Point <$> elements [0..9] 42 | <*> arbitrary 43 | <*> arbitrary 44 | main :: IO () 45 | main = hspec suite 46 | 47 | suite :: Spec 48 | suite = do 49 | describe "processBucket" $ do 50 | prop "has no elements later than end" propFilterNoLater 51 | prop "has no elements earlier than start" propFilterNoEarlier 52 | 53 | describe "first write deduplication" $ do 54 | it "must preserve first write" $ 55 | V.thaw (V.fromList [Point 0 0 0, Point 1 2 2, Point 1 2 3]) 56 | >>= A.deDuplicate A.similar 57 | >>= V.freeze 58 | >>= (`shouldBe` V.fromList [Point 0 0 0, Point 1 2 2]) 59 | 60 | prop "should retain no duplicates" $ propNoDuplicates (A.deDuplicate (==)) 61 | 62 | describe "last write deduplication" $ do 63 | it "last must preserve last write" $ 64 | V.thaw (V.fromList [Point 0 0 0, Point 1 2 2, Point 1 2 3]) 65 | >>= A.deDuplicateLast A.similar 66 | >>= V.freeze 67 | >>= (`shouldBe` V.fromList [Point 0 0 0, Point 1 2 3]) 68 | 69 | prop "should retain no duplicates" $ propNoDuplicates (A.deDuplicateLast (==)) 70 | 71 | describe "merging" $ 72 | it "correctly merges a pointer record and extended bucket" $ 73 | let merged = runST $ A.mergeSimpleExtended pointerRecord 74 | extendedRecord 75 | 5 76 | minBound 77 | maxBound 78 | in merged `shouldBe` mergedRecord 79 | 80 | pointerRecord :: ByteString 81 | pointerRecord = 82 | "\x05\x00\x00\x00\x00\x00\x00\x00\ 83 | \\x02\x00\x00\x00\x00\x00\x00\x00\ 84 | \\x02\x00\x00\x00\x00\x00\x00\x00" 85 | 86 | extendedRecord :: ByteString 87 | extendedRecord = 88 | "\x00\x00\ 89 | \\x03\x00\x00\x00\x00\x00\x00\x00\ 90 | \\x41\x42\x43" 91 | 92 | mergedRecord :: ByteString 93 | mergedRecord = 94 | "\x05\x00\x00\x00\x00\x00\x00\x00\ 95 | \\x02\x00\x00\x00\x00\x00\x00\x00\ 96 | \\x03\x00\x00\x00\x00\x00\x00\x00\ 97 | \\&ABC" 98 | 99 | type VectorF = (PrimMonad m, MVector v e, Ord e, Eq e) => v (PrimState m) e -> m (v (PrimState m) e) 100 | 101 | propNoDuplicates :: VectorF -> Vector Point -> Bool 102 | propNoDuplicates f v = 103 | noDups $ runST $ V.thaw v >>= (\v' -> M.sort v' >> f v') >>= V.freeze 104 | where 105 | noDups v' = V.foldr (\x acc -> acc && V.length (V.filter (== x) v') == 1) 106 | True 107 | v' 108 | 109 | propFilterNoLater :: AddrStartEnd -> Vector Point -> Bool 110 | propFilterNoLater (AddrStartEnd addr start end) v = 111 | let v' = byteStringToVector $ runST $ A.processBucket (vectorToByteString v) addr start end 112 | in V.null $ V.filter ((> end) . TimeStamp . A.time) v' 113 | 114 | propFilterNoEarlier :: AddrStartEnd -> Vector Point -> Bool 115 | propFilterNoEarlier (AddrStartEnd addr start end) v = 116 | let v' = byteStringToVector $ runST $ A.processBucket (vectorToByteString v) addr start end 117 | in V.null $ V.filter ((< start) . TimeStamp . A.time) v' 118 | -------------------------------------------------------------------------------- /tests/ReaderTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Main where 5 | 6 | import Control.Concurrent 7 | import Data.ByteString (ByteString) 8 | import qualified Data.ByteString as BS 9 | import Data.List.NonEmpty (fromList) 10 | import System.ZMQ4.Monadic 11 | import Test.Hspec hiding (pending) 12 | import TestHelpers 13 | 14 | main :: IO () 15 | main = do 16 | shutdown <- newEmptyMVar 17 | cleanupTestEnvironment 18 | startTestDaemons shutdown 19 | -- Prime vault by writing a test message to it 20 | sendTestMsg >>= (`shouldBe` ["\NUL"]) 21 | 22 | hspec suite 23 | 24 | putMVar shutdown () 25 | 26 | suite :: Spec 27 | suite = 28 | describe "full stack" $ do 29 | it "reads one simple message written by writer daemon" $ do 30 | -- Response is the data followed by an end of stream message 31 | let resp = ([simpleResponse], ["\x01"]) 32 | request simpleRequest >>= (`shouldBe` resp) 33 | 34 | it "reads one extended message written by writer daemon" $ do 35 | let resp = ([extendedResponse], ["\x01"]) 36 | request extendedRequest >>= (`shouldBe` resp) 37 | 38 | simpleResponse :: ByteString 39 | simpleResponse = 40 | "\x02" `BS.append` simpleMessage 41 | 42 | extendedResponse :: ByteString 43 | extendedResponse = 44 | "\x03" `BS.append` extendedMessage 45 | 46 | simpleRequest :: ByteString 47 | simpleRequest = "\x00\ 48 | \\x04\x00\x00\x00\x00\x00\x00\x00\ 49 | \\x00\x00\x00\x00\x00\x00\x00\x00\ 50 | \\xff\xff\xff\xff\xff\xff\xff\xff" 51 | 52 | extendedRequest :: ByteString 53 | extendedRequest = "\x01\ 54 | \\x05\x00\x00\x00\x00\x00\x00\x00\ 55 | \\x00\x00\x00\x00\x00\x00\x00\x00\ 56 | \\xff\xff\xff\xff\xff\xff\xff\xff" 57 | 58 | request :: ByteString -> IO ([ByteString], [ByteString]) 59 | request req = runZMQ $ do 60 | s <- socket Dealer 61 | connect s "tcp://localhost:5570" 62 | sendMulti s $ fromList ["PONY", req] 63 | rep <- receiveMulti s 64 | eof <- receiveMulti s 65 | return (rep, eof) 66 | -------------------------------------------------------------------------------- /tests/TestHelpers.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module TestHelpers 4 | ( 5 | cleanup, 6 | loadState, 7 | writePonyDayMap, 8 | throwJust, 9 | dayFileA, 10 | dayFileB, 11 | dayFileC, 12 | dayFileD, 13 | runTestDaemon, 14 | runTestPool, 15 | prettyPrint, 16 | extendedCompound, 17 | simpleCompound, 18 | simpleMessage, 19 | extendedMessage, 20 | sendTestMsg, 21 | startTestDaemons, 22 | cleanupTestEnvironment, 23 | readObject, 24 | daemonArgsTest 25 | ) 26 | where 27 | 28 | import Control.Applicative 29 | import Control.Concurrent 30 | import Control.Monad 31 | import Data.ByteString (ByteString) 32 | import qualified Data.ByteString as BS 33 | import Data.List.NonEmpty (fromList) 34 | import Data.Maybe 35 | import Network.URI 36 | import Numeric (showHex) 37 | import System.Rados.Monadic 38 | import System.ZMQ4.Monadic 39 | import Vaultaire.Broker 40 | import Vaultaire.Daemon 41 | import Vaultaire.Reader (startReader) 42 | import Vaultaire.RollOver 43 | import Vaultaire.Util 44 | import Vaultaire.Writer (startWriter) 45 | 46 | cleanup :: Daemon () 47 | cleanup = liftPool $ unsafeObjects >>= mapM_ (`runObject` remove) 48 | 49 | loadState :: Daemon () 50 | loadState = do 51 | writePonyDayMap "02_PONY_simple_days" dayFileA 52 | writePonyDayMap "02_PONY_extended_days" dayFileB 53 | refreshOriginDays "PONY" 54 | updateSimpleLatest "PONY" 0x42 55 | updateExtendedLatest "PONY" 0x52 56 | 57 | 58 | dayFileA, dayFileB, dayFileC, dayFileD:: ByteString 59 | dayFileA = "\x00\x00\x00\x00\x00\x00\x00\x00\ 60 | \\x08\x00\x00\x00\x00\x00\x00\x00" 61 | 62 | dayFileB = "\x00\x00\x00\x00\x00\x00\x00\x00\ 63 | \\x0f\x00\x00\x00\x00\x00\x00\x00" 64 | 65 | dayFileC = "\x00\x00\x00\x00\x00\x00\x00\x00\ 66 | \\x0f\x00\x00\x00\x00\x00\x00\x00\ 67 | \\xff\x00\x00\x00\x00\x00\x00\x00\ 68 | \\xfe\x00\x00\x00\x00\x00\x00\x00" 69 | 70 | dayFileD = "\x00\x00\x00\x00\x00\x00\x00\x00\ 71 | \\x08\x00\x00\x00\x00\x00\x00\x00\ 72 | \\x42\x00\x00\x00\x00\x00\x00\x00\ 73 | \\x08\x00\x00\x00\x00\x00\x00\x00" 74 | 75 | writePonyDayMap :: ByteString -> ByteString -> Daemon () 76 | writePonyDayMap oid contents = liftPool $ 77 | runObject oid (writeFull contents) 78 | >>= throwJust 79 | 80 | throwJust :: Monad m => Maybe RadosError -> m () 81 | throwJust = 82 | maybe (return ()) (error . show) 83 | 84 | runTestDaemon :: String -> Daemon a -> IO a 85 | runTestDaemon brokerURI a = 86 | join $ flip runDaemon (cleanup >> loadState >> a) 87 | <$> daemonArgsTest (fromJust $ parseURI brokerURI) 88 | Nothing "test" 89 | 90 | cleanupTestEnvironment :: IO () 91 | cleanupTestEnvironment = runTestDaemon "tcp://localhost:1234" (return ()) 92 | 93 | runTestPool :: Pool a -> IO a 94 | runTestPool = runConnect Nothing (parseConfig "/etc/ceph/ceph.conf") 95 | . runPool "test" 96 | 97 | prettyPrint :: ByteString -> String 98 | prettyPrint = concatMap (`showHex` "") . BS.unpack 99 | 100 | extendedCompound, simpleCompound, simpleMessage, extendedMessage :: ByteString 101 | 102 | extendedCompound = simpleMessage `BS.append` extendedMessage 103 | 104 | simpleCompound = simpleMessage `BS.append` simpleMessage 105 | 106 | simpleMessage = 107 | "\x04\x00\x00\x00\x00\x00\x00\x00\ 108 | \\x02\x00\x00\x00\x00\x00\x00\x00\ 109 | \\x01\x00\x00\x00\x00\x00\x00\x00" 110 | 111 | extendedMessage = 112 | "\x05\x00\x00\x00\x00\x00\x00\x00\ 113 | \\x02\x00\x00\x00\x00\x00\x00\x00\ 114 | \\x1f\x00\x00\x00\x00\x00\x00\x00\ 115 | \\&This computer is made of warms.\ 116 | \\x05\x00\x00\x00\x00\x00\x00\x00\ 117 | \\x03\x00\x00\x00\x00\x00\x00\x00\ 118 | \\x04\x00\x00\x00\x00\x00\x00\x00\ 119 | \\&Yay!" 120 | 121 | sendTestMsg :: IO [ByteString] 122 | sendTestMsg = runZMQ $ do 123 | s <- socket Dealer 124 | connect s "tcp://localhost:5560" 125 | -- Simulate a client sending a sequence number and message 126 | sendMulti s $ fromList ["PONY", extendedCompound] 127 | receiveMulti s 128 | 129 | startTestDaemons :: MVar () -> IO () 130 | startTestDaemons shutdown = do 131 | linkThread $ do 132 | runZMQ $ startProxy (Router,"tcp://*:5560") 133 | (Dealer,"tcp://*:5561") 134 | "tcp://*:5000" 135 | readMVar shutdown 136 | 137 | linkThread $ do 138 | runZMQ $ startProxy (Router,"tcp://*:5570") 139 | (Dealer,"tcp://*:5571") 140 | "tcp://*:5001" 141 | readMVar shutdown 142 | 143 | argsw <- daemonArgsDefault (fromJust $ parseURI "tcp://localhost:5561") 144 | Nothing "test" shutdown 145 | argsr <- daemonArgsDefault (fromJust $ parseURI "tcp://localhost:5571") 146 | Nothing "test" shutdown 147 | 148 | linkThread $ startWriter argsw 0 149 | linkThread $ startReader argsr 150 | 151 | readObject :: ByteString -> IO (Either RadosError ByteString) 152 | readObject = runTestPool . flip runObject readFull 153 | 154 | daemonArgsTest :: URI -> Maybe String -> String -> IO DaemonArgs 155 | daemonArgsTest broker_uri user pool = do 156 | x <- newEmptyMVar 157 | daemonArgsDefault broker_uri user pool x 158 | -------------------------------------------------------------------------------- /tests/WriterTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Main where 4 | 5 | import Control.Applicative 6 | import Control.Concurrent hiding (yield) 7 | import Control.Monad.State.Strict 8 | import Data.ByteString (ByteString) 9 | import qualified Data.ByteString as BS 10 | import Data.ByteString.Lazy (toStrict) 11 | import Data.ByteString.Lazy.Builder 12 | import qualified Data.HashMap.Strict as HashMap 13 | import Data.List (sort) 14 | import Data.Maybe 15 | import Data.Monoid 16 | import Data.Time 17 | import Network.URI 18 | import System.Rados.Monadic 19 | import System.ZMQ4.Monadic 20 | import Test.Hspec hiding (pending) 21 | 22 | import TestHelpers 23 | import Vaultaire.Broker 24 | import Vaultaire.Daemon 25 | import Vaultaire.DayMap 26 | import Vaultaire.Util 27 | import Vaultaire.Writer 28 | 29 | main :: IO () 30 | main = do 31 | now <- getCurrentTime 32 | hspec (suite now) 33 | 34 | suite :: UTCTime -> Spec 35 | suite now = do 36 | describe "appendSimple" $ do 37 | it "generates a single builder from one append" $ do 38 | let st = go $ appendSimple 0 1 "HAI" 39 | let builder = HashMap.lookup 0 (simple st) >>= HashMap.lookup 1 40 | case builder of Nothing -> error "lookup" 41 | Just b -> toLazyByteString b `shouldBe` "HAI" 42 | 43 | it "generates a single builder from one append" $ do 44 | let st = go $ appendSimple 0 1 "A" >> appendSimple 0 1 "B" 45 | let builder = HashMap.lookup 0 (simple st) >>= HashMap.lookup 1 46 | case builder of Nothing -> error "lookup" 47 | Just b -> toLazyByteString b `shouldBe` "AB" 48 | 49 | describe "appendExtended" $ 50 | it "creates appropriate builders and extended map" $ do 51 | let st = go $ appendExtended 0 1 0x42 0x90 2 "BC" 52 | 53 | let ext_bytes = "\x02\x00\x00\x00\x00\x00\x00\x00\&BC" 54 | let ext = HashMap.lookup 0 (extended st) >>= HashMap.lookup 1 55 | case ext of Nothing -> error "lookup extended" 56 | Just b -> toLazyByteString b `shouldBe` ext_bytes 57 | 58 | let pend = HashMap.lookup 0 (pending st) >>= HashMap.lookup 1 59 | let pend_bytes = "\x42\x00\x00\x00\x00\x00\x00\x00\ 60 | \\x90\x00\x00\x00\x00\x00\x00\x00\ 61 | \\10\x00\x00\x00\x00\x00\x00\x00" 62 | case pend of 63 | Nothing -> error "lookup pending" 64 | Just fs -> let b = mconcat $ map ($10) (snd fs) 65 | in toLazyByteString b `shouldBe` pend_bytes 66 | 67 | describe "processPoints" $ do 68 | it "handles multiple simple points" $ do 69 | let st = go $ processPoints 0 simpleCompound 70 | startDayMaps "PONY" 0 0 71 | HashMap.null (extended st) `shouldBe` True 72 | HashMap.null (pending st) `shouldBe` True 73 | HashMap.null (simple st) `shouldBe` False 74 | let norm = HashMap.lookup 0 (simple st) >>= HashMap.lookup 4 75 | case norm of Nothing -> error "bucket got lost" 76 | Just b -> toStrict (toLazyByteString b) 77 | 78 | `shouldBe` simpleCompound 79 | 80 | HashMap.null (simple st) `shouldBe` False 81 | latestSimple st `shouldBe` 2 82 | latestExtended st `shouldBe` 0 83 | 84 | it "handles multiple simple and extended points" $ do 85 | let st = go $ processPoints 0 extendedCompound 86 | startDayMaps "PONY" 0 0 87 | HashMap.null (extended st) `shouldBe` False 88 | HashMap.null (pending st) `shouldBe` False 89 | HashMap.null (simple st) `shouldBe` False 90 | 91 | -- Simple bucket should have only simple points 92 | let norm = HashMap.lookup 0 (simple st) >>= HashMap.lookup 4 93 | case norm of Nothing -> error "simple bucket got lost" 94 | Just b -> toStrict (toLazyByteString b) 95 | `shouldBe` simpleMessage 96 | 97 | -- Extended bucket should have the length and string 98 | let ext = HashMap.lookup 0 (extended st) >>= HashMap.lookup 4 99 | case ext of 100 | Nothing -> error "extended bucket got lost" 101 | Just b -> toStrict (toLazyByteString b) 102 | `shouldBe` extendedBytes 103 | 104 | -- Pending bucket should have a closure that creates a pointer to 105 | -- the extended bucket given an offset. These should point to 0x0 106 | -- and then 0x27 (length 0x1f + header 0x8) reference the offset. 107 | -- (so 0x2 0x21 given os 0x2) 108 | -- 109 | -- Note that to achieve the expected ordering we must reverse the 110 | -- list before concatenation. This is due to prepending to the list 111 | -- for efficiency. 112 | 113 | let pend = HashMap.lookup 0 (pending st) >>= HashMap.lookup 4 114 | case pend of 115 | Nothing -> error "lookup pending" 116 | Just fs -> let b = mconcat . reverse $ map ($2) (snd fs) 117 | in toStrict (toLazyByteString b) `shouldBe` pendingBytes 118 | 119 | latestSimple st `shouldBe` 2 120 | latestExtended st `shouldBe` 3 121 | 122 | describe "full stack" $ 123 | it "writes a message to disk immediately" $ do 124 | -- Clean up latest files so that we can test that we are writing 125 | -- correct values 126 | _ <- runTestDaemon "tcp://localhost:1234" $ liftPool $ do 127 | _ <- runObject "02_PONY_extended_latest" remove 128 | runObject "02_PONY_simple_latest" remove 129 | 130 | 131 | shutdown <- newEmptyMVar 132 | linkThread $ do 133 | runZMQ $ startProxy (Router,"tcp://*:5560") 134 | (Dealer,"tcp://*:5561") "tcp://*:5000" 135 | readMVar shutdown 136 | 137 | args <- daemonArgsDefault (fromJust $ parseURI "tcp://localhost:5561") 138 | Nothing "test" shutdown 139 | linkThread $ startWriter args 0 140 | 141 | sendTestMsg >>= (`shouldBe` ["\NUL"]) 142 | 143 | let expected = sort [ "02_PONY_00000000000000000004_00000000000000000000_extended" 144 | , "02_PONY_00000000000000000004_00000000000000000000_simple" 145 | , "02_PONY_extended_latest" 146 | , "02_PONY_simple_latest" 147 | , "02_PONY_simple_days" 148 | , "02_PONY_write_lock" 149 | , "02_PONY_extended_days"] 150 | 151 | runTestPool (sort <$> objects) >>= (`shouldBe` expected) 152 | 153 | sim <- runTestPool $ 154 | runObject "02_PONY_00000000000000000004_00000000000000000000_simple" readFull 155 | sim `shouldBe` Right (extendedPointers `BS.append` simpleMessage) 156 | 157 | ext <- runTestPool $ 158 | runObject "02_PONY_00000000000000000004_00000000000000000000_extended" readFull 159 | ext `shouldBe` Right extendedBytes 160 | 161 | runTestPool (runObject "02_PONY_extended_latest" readFull) 162 | >>= (`shouldBe` Right "\x03\x00\x00\x00\x00\x00\x00\x00") 163 | 164 | runTestPool (runObject "02_PONY_simple_latest" readFull) 165 | >>= (`shouldBe` Right "\x02\x00\x00\x00\x00\x00\x00\x00") 166 | 167 | where 168 | go = flip execState (startState now) 169 | 170 | extendedBytes :: ByteString 171 | extendedBytes = "\x1f\x00\x00\x00\x00\x00\x00\x00\ 172 | \\&This computer is made of warms.\ 173 | \\x04\x00\x00\x00\x00\x00\x00\x00\ 174 | \\&Yay!" 175 | 176 | extendedPointers :: ByteString 177 | extendedPointers = "\x05\x00\x00\x00\x00\x00\x00\x00\ 178 | \\x02\x00\x00\x00\x00\x00\x00\x00\ 179 | \\x00\x00\x00\x00\x00\x00\x00\x00\ 180 | \\x05\x00\x00\x00\x00\x00\x00\x00\ 181 | \\x03\x00\x00\x00\x00\x00\x00\x00\ 182 | \\x27\x00\x00\x00\x00\x00\x00\x00" 183 | 184 | pendingBytes :: ByteString 185 | pendingBytes = "\x05\x00\x00\x00\x00\x00\x00\x00\ 186 | \\x02\x00\x00\x00\x00\x00\x00\x00\ 187 | \\x02\x00\x00\x00\x00\x00\x00\x00\ 188 | \\x05\x00\x00\x00\x00\x00\x00\x00\ 189 | \\x03\x00\x00\x00\x00\x00\x00\x00\ 190 | \\x29\x00\x00\x00\x00\x00\x00\x00" 191 | 192 | startDayMaps :: (DayMap, DayMap) 193 | startDayMaps = 194 | let norm = loadDayMap "\x00\x00\x00\x00\x00\x00\x00\x00\ 195 | \\x42\x00\x00\x00\x00\x00\x00\x00" 196 | ext = loadDayMap "\x00\x00\x00\x00\x00\x00\x00\x00\ 197 | \\x42\x00\x00\x00\x00\x00\x00\x00" 198 | in either error id $ (,) <$> norm <*> ext 199 | 200 | startState :: UTCTime -> BatchState 201 | startState = BatchState mempty mempty mempty 0 0 startDayMaps 0 202 | -------------------------------------------------------------------------------- /vaultaire.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: >= 1.10 2 | name: vaultaire 3 | version: 2.6.2.1 4 | synopsis: Data vault for metrics 5 | description: Data vault for metrics 6 | license: BSD3 7 | license-file: LICENCE 8 | author: Anchor Engineering 9 | maintainer: Anchor Engineering 10 | copyright: © 2013-2014 Anchor Systems, Pty Ltd and Others 11 | category: Other 12 | tested-with: GHC == 7.8.3 13 | stability: experimental 14 | 15 | build-type: Custom 16 | 17 | source-repository head 18 | type: git 19 | location: git@github.com:anchor/vaultaire.git 20 | 21 | flag network-uri 22 | description: Get Network.URI from the network-uri package 23 | default: True 24 | 25 | library 26 | hs-source-dirs: lib 27 | default-language: Haskell2010 28 | 29 | exposed-modules: Vaultaire.Daemon, 30 | Vaultaire.RollOver, 31 | Vaultaire.Broker, 32 | Vaultaire.DayMap, 33 | Vaultaire.Origin, 34 | Vaultaire.OriginMap, 35 | Vaultaire.Writer, 36 | Vaultaire.Reader, 37 | Vaultaire.ReaderAlgorithms, 38 | Vaultaire.InternalStore, 39 | Vaultaire.Contents, 40 | Vaultaire.Profiler 41 | 42 | if flag(network-uri) 43 | build-depends: network-uri >= 2.6, network >= 2.6 44 | else 45 | build-depends: network-uri < 2.6, network < 2.6 46 | build-depends: base >=4.7.0.1 && <5, 47 | bytestring, 48 | blaze-markup <= 0.6.2, 49 | random, 50 | zeromq4-haskell, 51 | containers, 52 | pipes-parse, 53 | pipes, 54 | mtl, 55 | transformers, 56 | unordered-containers, 57 | primitive, 58 | vector-algorithms, 59 | vector, 60 | spool, 61 | packer, 62 | time, 63 | pipes-concurrency, 64 | async, 65 | stm, 66 | semigroups, 67 | hslogger >= 1.2.4, 68 | vaultaire-common >= 2.9, 69 | text, 70 | unix, 71 | unix-time, 72 | rados-haskell >= 3.0.3 73 | 74 | ghc-options: -O2 75 | -Wall 76 | -Wwarn 77 | -fwarn-tabs 78 | 79 | ghc-prof-options: -fprof-auto 80 | 81 | 82 | executable vault 83 | hs-source-dirs: src 84 | main-is: Vault.hs 85 | default-language: Haskell2010 86 | 87 | if flag(network-uri) 88 | build-depends: network-uri >= 2.6, network >= 2.6 89 | else 90 | build-depends: network-uri < 2.6, network < 2.6 91 | build-depends: base >= 4.7.0.1 && <5, 92 | bytestring, 93 | rados-haskell, 94 | zeromq4-haskell, 95 | optparse-applicative, 96 | trifecta >= 1.4.3, 97 | directory, 98 | marquise >= 4.0.0, 99 | containers, 100 | vaultaire-common >= 2.9, 101 | pipes, 102 | hslogger >= 1.2.4, 103 | async, 104 | unix, 105 | vaultaire 106 | 107 | ghc-options: -O2 108 | -threaded 109 | -Wall 110 | -Wwarn 111 | -fwarn-tabs 112 | 113 | ghc-prof-options: -fprof-auto 114 | 115 | executable inspect 116 | hs-source-dirs: src 117 | main-is: Inspect.hs 118 | default-language: Haskell2010 119 | 120 | if flag(network-uri) 121 | build-depends: network-uri >= 2.6, network >= 2.6 122 | else 123 | build-depends: network-uri < 2.6, network < 2.6 124 | build-depends: base >= 4.7.0.1 && <5, 125 | bytestring, 126 | rados-haskell, 127 | zeromq4-haskell, 128 | optparse-applicative, 129 | trifecta >= 1.4.3, 130 | directory, 131 | marquise >= 4.0.0, 132 | containers, 133 | vaultaire-common >= 2.9, 134 | pipes, 135 | hslogger >= 1.2.4, 136 | async, 137 | unix, 138 | vaultaire 139 | 140 | ghc-options: -O2 141 | -threaded 142 | -Wall 143 | -Wwarn 144 | -fwarn-tabs 145 | 146 | ghc-prof-options: -fprof-auto 147 | 148 | executable demowave 149 | hs-source-dirs: src 150 | main-is: DemoWave.hs 151 | default-language: Haskell2010 152 | 153 | build-depends: base >=3 && <5, 154 | bytestring, 155 | rados-haskell, 156 | zeromq4-haskell, 157 | optparse-applicative, 158 | trifecta, 159 | directory, 160 | marquise >= 4.0.0, 161 | containers, 162 | vaultaire-common >= 2.9, 163 | pipes, 164 | hslogger, 165 | time, 166 | data-binary-ieee754, 167 | async, 168 | vaultaire 169 | 170 | ghc-options: -O2 171 | -threaded 172 | -Wall 173 | -Wwarn 174 | -fwarn-tabs 175 | 176 | ghc-prof-options: -fprof-auto 177 | 178 | executable telemetry 179 | hs-source-dirs: src 180 | main-is: TelemetryProgram.hs 181 | default-language: Haskell2010 182 | 183 | build-depends: base >=3 && <5, 184 | network, 185 | network-uri, 186 | optparse-applicative >= 0.11.0, 187 | zeromq4-haskell, 188 | vaultaire-common >= 2.9, 189 | vaultaire 190 | 191 | ghc-options: -O2 192 | -threaded 193 | -Wall 194 | -Wwarn 195 | -fwarn-tabs 196 | 197 | ghc-prof-options: -fprof-auto 198 | 199 | test-suite daemon-test 200 | hs-source-dirs: tests 201 | main-is: DaemonTest.hs 202 | type: exitcode-stdio-1.0 203 | default-language: Haskell2010 204 | 205 | if flag(network-uri) 206 | build-depends: network-uri >= 2.6, network >= 2.6 207 | else 208 | build-depends: network-uri < 2.6, network < 2.6 209 | build-depends: base >=3 && <5, 210 | hspec, 211 | async, 212 | vaultaire-common >= 2.9, 213 | semigroups, 214 | bytestring, 215 | vaultaire, 216 | zeromq4-haskell, 217 | rados-haskell >= 3.0.1 218 | 219 | ghc-options: -fwarn-incomplete-patterns -threaded 220 | 221 | test-suite daymap-test 222 | hs-source-dirs: tests 223 | main-is: DayMapTest.hs 224 | type: exitcode-stdio-1.0 225 | default-language: Haskell2010 226 | 227 | build-depends: base >=3 && <5, 228 | hspec, 229 | containers, 230 | bytestring, 231 | vaultaire 232 | 233 | ghc-options: -O2 234 | -threaded 235 | -Wall 236 | -Wwarn 237 | -fwarn-tabs 238 | 239 | 240 | test-suite writer-test 241 | hs-source-dirs: tests 242 | main-is: WriterTest.hs 243 | type: exitcode-stdio-1.0 244 | default-language: Haskell2010 245 | 246 | if flag(network-uri) 247 | build-depends: network-uri >= 2.6, network >= 2.6 248 | else 249 | build-depends: network-uri < 2.6, network < 2.6 250 | build-depends: base >=3 && <5, 251 | hspec, 252 | containers, 253 | time, 254 | pipes, 255 | pipes-parse, 256 | semigroups, 257 | vaultaire-common >= 2.9, 258 | zeromq4-haskell, 259 | mtl, 260 | bytestring, 261 | unordered-containers, 262 | rados-haskell >= 3.0.1, 263 | vaultaire 264 | 265 | 266 | ghc-options: -O2 267 | -threaded 268 | -Wall 269 | -Wwarn 270 | -fwarn-tabs 271 | 272 | 273 | test-suite reader-test 274 | hs-source-dirs: tests 275 | main-is: ReaderTest.hs 276 | type: exitcode-stdio-1.0 277 | default-language: Haskell2010 278 | 279 | if flag(network-uri) 280 | build-depends: network-uri >= 2.6, network >= 2.6 281 | else 282 | build-depends: network-uri < 2.6, network < 2.6 283 | build-depends: base >=3 && <5, 284 | hspec, 285 | containers, 286 | time, 287 | pipes, 288 | pipes-parse, 289 | semigroups, 290 | vaultaire-common >= 2.9, 291 | zeromq4-haskell, 292 | mtl, 293 | bytestring, 294 | unordered-containers, 295 | rados-haskell >= 3.0.1, 296 | vaultaire 297 | 298 | ghc-options: -O2 299 | -threaded 300 | -Wall 301 | -Wwarn 302 | -fwarn-tabs 303 | 304 | 305 | test-suite reader-algorithms-test 306 | hs-source-dirs: tests 307 | main-is: ReaderAlgorithms.hs 308 | type: exitcode-stdio-1.0 309 | default-language: Haskell2010 310 | 311 | build-depends: base >=3 && <5, 312 | hspec, 313 | containers, 314 | QuickCheck, 315 | primitive, 316 | vaultaire-common >= 2.9, 317 | spool, 318 | vector, 319 | mtl, 320 | vector-algorithms, 321 | bytestring, 322 | vaultaire 323 | 324 | 325 | ghc-options: -O2 326 | -threaded 327 | -Wall 328 | -Wwarn 329 | -fwarn-tabs 330 | 331 | test-suite internal-store-test 332 | hs-source-dirs: tests 333 | main-is: InternalStoreTest.hs 334 | type: exitcode-stdio-1.0 335 | default-language: Haskell2010 336 | 337 | if flag(network-uri) 338 | build-depends: network-uri >= 2.6, network >= 2.6 339 | else 340 | build-depends: network-uri < 2.6, network < 2.6 341 | build-depends: base >=3 && <5, 342 | hspec, 343 | containers, 344 | QuickCheck, 345 | vector, 346 | rados-haskell, 347 | semigroups, 348 | locators >= 0.2.4, 349 | pipes-parse, 350 | mtl, 351 | vaultaire-common >= 2.9, 352 | bytestring, 353 | zeromq4-haskell, 354 | vaultaire 355 | 356 | ghc-options: -O2 357 | -threaded 358 | -Wall 359 | -Wwarn 360 | -fwarn-tabs 361 | 362 | test-suite contents-test 363 | hs-source-dirs: tests 364 | main-is: ContentsTest.hs 365 | type: exitcode-stdio-1.0 366 | default-language: Haskell2010 367 | 368 | if flag(network-uri) 369 | build-depends: network-uri >= 2.6, network >= 2.6 370 | else 371 | build-depends: network-uri < 2.6, network < 2.6 372 | build-depends: base >=3 && <5, 373 | hspec, 374 | containers, 375 | unordered-containers, 376 | hashable, 377 | text, 378 | QuickCheck, 379 | vector, 380 | rados-haskell, 381 | semigroups, 382 | locators >= 0.2.4, 383 | mtl, 384 | marquise >= 4.0.0, 385 | bytestring, 386 | zeromq4-haskell, 387 | vaultaire-common >= 2.9, 388 | pipes, 389 | vaultaire 390 | 391 | ghc-options: -O2 392 | -threaded 393 | -Wall 394 | -Wwarn 395 | -fwarn-tabs 396 | 397 | test-suite integration-test 398 | hs-source-dirs: tests,src 399 | main-is: IntegrationTest.hs 400 | type: exitcode-stdio-1.0 401 | default-language: Haskell2010 402 | 403 | if flag(network-uri) 404 | build-depends: network-uri >= 2.6, network >= 2.6 405 | else 406 | build-depends: network-uri < 2.6, network < 2.6 407 | build-depends: base >=3 && <5, 408 | hspec, 409 | containers, 410 | unordered-containers, 411 | text, 412 | QuickCheck, 413 | marquise >= 4.0.0, 414 | bytestring, 415 | pipes, 416 | semigroups, 417 | async, 418 | hslogger >= 1.2.4, 419 | zeromq4-haskell, 420 | rados-haskell >= 3.0.1, 421 | directory, 422 | vaultaire-common >= 2.9, 423 | vaultaire 424 | 425 | ghc-options: -O2 426 | -threaded 427 | -Wall 428 | -Wwarn 429 | -fwarn-tabs 430 | 431 | benchmark writer-bench 432 | hs-source-dirs: bench, tests 433 | main-is: Writer.hs 434 | type: exitcode-stdio-1.0 435 | default-language: Haskell2010 436 | 437 | build-depends: base >=3 && <5, 438 | bytestring, 439 | zeromq4-haskell, 440 | semigroups, 441 | rados-haskell, 442 | criterion, 443 | vaultaire-common >= 2.9, 444 | vaultaire 445 | 446 | ghc-options: -O2 447 | -threaded 448 | -Wall 449 | -Wwarn 450 | -fwarn-tabs 451 | 452 | 453 | benchmark reader-algorithms 454 | hs-source-dirs: bench 455 | main-is: ReaderAlgorithms.hs 456 | type: exitcode-stdio-1.0 457 | default-language: Haskell2010 458 | 459 | build-depends: base >=3 && <5, 460 | bytestring, 461 | criterion, 462 | vector, 463 | spool, 464 | vaultaire 465 | 466 | ghc-options: -O2 467 | -threaded 468 | -Wall 469 | -Wwarn 470 | -fwarn-tabs 471 | 472 | ghc-prof-options: -fprof-auto 473 | 474 | benchmark contents-listing 475 | hs-source-dirs: bench 476 | main-is: ContentsListing.hs 477 | type: exitcode-stdio-1.0 478 | default-language: Haskell2010 479 | 480 | build-depends: base >=3 && <5, 481 | bytestring, 482 | criterion, 483 | zeromq4-haskell, 484 | vaultaire-common >= 2.9, 485 | marquise >= 4.0.0, 486 | vaultaire 487 | 488 | ghc-options: -O2 489 | -threaded 490 | -Wall 491 | -Wwarn 492 | -fwarn-tabs 493 | 494 | test-suite profiler-test 495 | hs-source-dirs: tests,src 496 | main-is: ProfilerTest.hs 497 | type: exitcode-stdio-1.0 498 | default-language: Haskell2010 499 | 500 | if flag(network-uri) 501 | build-depends: network-uri >= 2.6, network >= 2.6 502 | else 503 | build-depends: network-uri < 2.6, network < 2.6 504 | build-depends: base >=3 && <5, 505 | hspec, 506 | QuickCheck, 507 | marquise >= 4.0.0, 508 | bytestring, 509 | pipes, 510 | semigroups, 511 | async, 512 | zeromq4-haskell, 513 | rados-haskell >= 3.0.1, 514 | mtl, 515 | transformers, 516 | vaultaire-common >= 2.9, 517 | vaultaire 518 | 519 | ghc-options: -O2 520 | -threaded 521 | -Wall 522 | -Wwarn 523 | -fwarn-tabs 524 | 525 | -- vim: set tabstop=21 expandtab: 526 | --------------------------------------------------------------------------------