borel (empty) → 0.18.0
raw patch · 14 files changed
+1525/−0 lines, 14 filesdep +QuickCheckdep +aesondep +asyncsetup-changed
Dependencies added: QuickCheck, aeson, async, attoparsec, base, bimap, cassava, ceilometer-common, chevalier-common, configurator, containers, either, errors, hslogger, hspec, lens, lens-properties, marquise, mtl, multiset, network, network-uri, pipes, pipes-concurrency, pipes-safe, text, time, transformers, unordered-containers, vaultaire-common, vector, zeromq4-haskell
Files
- LICENSE +22/−0
- Setup.hs +2/−0
- borel.cabal +122/−0
- lib/Borel.hs +173/−0
- lib/Borel/Ceilometer.hs +54/−0
- lib/Borel/Ceilometer/Instance.hs +26/−0
- lib/Borel/Chevalier.hs +128/−0
- lib/Borel/Error.hs +54/−0
- lib/Borel/Marquise.hs +86/−0
- lib/Borel/Types.hs +233/−0
- lib/Borel/Types/Metric.hs +117/−0
- lib/Borel/Types/Result.hs +96/−0
- lib/Borel/Types/UOM.hs +264/−0
- tests/Main.hs +148/−0
+ LICENSE view
@@ -0,0 +1,22 @@+The MIT License (MIT)++Copyright (c) 2014 Anchor++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ borel.cabal view
@@ -0,0 +1,122 @@+name: borel+version: 0.18.0+synopsis: Metering System for OpenStack metrics provided by Vaultaire.+description: Leverages Ceilometer, Chevalier and Marquise to meter OpenStack data.+homepage: https://github.com/anchor/borel-core+license: BSD3+license-file: LICENSE+author: Anchor Engineering <engineering@anchor.com.au>+maintainer: Anchor Engineering <engineering@anchor.com.au>+copyright: © 2014-2015 Anchor Systems, Pty Ltd and Others+tested-with: GHC == 7.8.3+stability: experimental+category: Development+build-type: Simple+cabal-version: >=1.18++flag network-uri+ description: Get Network.URI from the network-uri package+ default: True++source-repository head+ type: git+ location: git@github.com:anchor/borel.git++library+ hs-source-dirs: lib+ default-language: Haskell2010++ exposed-modules: Borel+ Borel.Types++ other-modules: Borel.Types.UOM+ Borel.Types.Metric+ Borel.Types.Result+ Borel.Error+ Borel.Marquise+ Borel.Chevalier+ Borel.Ceilometer+ Borel.Ceilometer.Instance++ if flag(network-uri)+ build-depends: network-uri >= 2.6, network >= 2.6+ else+ build-depends: network-uri < 2.6, network < 2.6++ build-depends: base >=4.7 && <4.8+ , aeson >= 0.8+ , async+ , attoparsec >= 0.12+ , bimap >= 0.2+ , cassava >= 0.4+ , containers >=0.5 && <0.6+ , unordered-containers >= 0.2.4+ , configurator >= 0.3+ , errors >= 1.4+ , hslogger >= 1.2+ , lens >= 4.6+ , mtl >= 2.1+ , multiset >= 0.2+ , pipes >= 4.1+ , pipes-concurrency >=2.0+ , pipes-safe >= 2.2+ , text >= 1.2+ , time >= 1.4+ , transformers >= 0.3+ , vector >= 0.10+ , zeromq4-haskell >= 0.6.3+ , ceilometer-common >= 0.2.2+ , chevalier-common >= 0.4.0+ , marquise >= 4.0.0+ , vaultaire-common >= 2.8.3++ ghc-options: -O2+ -Wall+ -Wwarn+ -fwarn-tabs++ ghc-prof-options: -fprof-auto++test-suite unit+ type: exitcode-stdio-1.0+ default-language: Haskell2010+ hs-source-dirs: tests,lib++ main-is: Main.hs++ if flag(network-uri)+ build-depends: network-uri >= 2.6, network >= 2.6+ else+ build-depends: network-uri < 2.6, network < 2.6++ build-depends: base >=4.7 && < 5+ , lens-properties >= 4.7+ , hspec >= 2.1+ , QuickCheck >= 2.7+ , aeson >= 0.8+ , async+ , cassava >= 0.4+ , attoparsec >= 0.12+ , bimap >= 0.2+ , containers >=0.5 && <0.6+ , unordered-containers >= 0.2.4+ , configurator >= 0.3+ , errors >= 1.4+ , either >= 4.3+ , hslogger >= 1.2+ , lens >= 4.6+ , mtl >= 2.1+ , multiset >= 0.2+ , pipes >= 4.1+ , pipes-concurrency >= 2.0+ , pipes-safe >= 2.2+ , text >= 1.2+ , time >= 1.4+ , transformers >= 0.3+ , vector >= 0.10+ , zeromq4-haskell >= 0.6.3+ , ceilometer-common >= 0.2.2+ , chevalier-common >= 0.4.0+ , marquise >= 4.0.0+ , vaultaire-common >= 2.8.3+
+ lib/Borel.hs view
@@ -0,0 +1,173 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MonadComprehensions #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeOperators #-}++module Borel+ ( -- * Metric+ Metric(..)+ , cpu, block, ssd, diskReads, diskWrites, neutronIn, neutronOut+ , ipv4, vcpus, memory, snapshot, image+ , mkInstance++ -- * Unit of measurement+ , UOM(..), BaseUOM(..), Prefix(..)+ , nanosec, byte, megabyte, gigabyte+ , countCPU, countVCPU, countInstance, countIP+ , convert+ , nanosecToSec, nanosecToHour, byteToGigabyte++ -- * BorelConfig+ , BorelConfig(..)+ , mkBorelConfig, parseBorelConfig, loadBorelConfig+ , allInstances, allMetrics+ , paramBorelConfig, paramFlavorMap, paramOrigins, paramMarquiseURI, paramChevalierURI++ -- * Query arguments+ , BorelEnv+ , paramStart, paramEnd, paramMetrics, paramTID+ , TenancyID(..)++ -- * Query results+ , ResponseItem(..)+ , mkItem+ , respResource, respResourceID, respVal+ , uomVal++ -- * Running+ , run, runF+ , BorelError(..)++ ) where++import Control.Applicative+import Control.Concurrent.Async+import qualified Control.Exception as E+import Control.Lens+import Control.Monad.Reader+import Data.Set (Set)+import qualified Data.Set as S+import Pipes hiding (Proxy)+import qualified Pipes as P+import Pipes.Concurrent+import qualified Pipes.Prelude as P+import Pipes.Safe+import System.Log.Logger++-- friends+import Ceilometer.Client+import Vaultaire.Types++-- family+import Borel.Ceilometer+import Borel.Chevalier+import Borel.Marquise+import Borel.Types+++--------------------------------------------------------------------------------++-- | Metrics that must be queried as a common Ceilometer resource are grouped together,+-- others are left as-is.+--+-- e.g. [instance-1, instance-2,..]+--+groupMetrics :: Set Metric -- ^ All available instances+ -> Set Metric -- ^ Metrics to be grouped+ -> Set GroupedMetric+groupMetrics instances metrics =+ let (allfs, nonfs) = bimap S.toList (S.map pure) $ S.partition (`S.member` instances) metrics+ in case allfs of+ [] -> nonfs+ xs -> S.insert xs nonfs+++--------------------------------------------------------------------------------++-- | Leverages Chevalier, Marquise and Ceilometer+-- to find, fetch, decode and aggregate data for an OpenStack tenancy.+--+run :: (MonadSafe m, Applicative m)+ => BorelConfig -- ^ Borel config, e.g. contains Chevalier/Marquise URI.+ -> Set Metric -- ^ Metrics requested+ -> TenancyID -- ^ OpenStack tenancy (can lead to multiple metrics)+ -> TimeStamp -- ^ Start time+ -> TimeStamp -- ^ End time+ -> Producer ResponseItem m ()+run conf ms tid s e = runBorel conf ms tid s e (query >-> P.map snd)++-- | Acts like a functor over the produced results.+-- This is not a Haskell functor, it's a functor between Hask and cat of Proxy composition.+--+runF :: (MonadSafe m, Applicative m)+ => ((Metric, ResponseItem) -> a)+ -> BorelConfig -- ^ Borel config, e.g. contains Chevalier/Marquise URI.+ -> Set Metric -- ^ Metrics requested+ -> TenancyID -- ^ OpenStack tenancy (can lead to multiple metrics)+ -> TimeStamp -- ^ Start time+ -> TimeStamp -- ^ End time+ -> Producer a m ()+runF f conf ms tid s e = runBorel conf ms tid s e (query >-> P.map f)++query :: (Applicative m, MonadSafe m, MonadIO m)+ => Producer (Metric, ResponseItem) (BorelS m) ()+query = do+ liftIO $ updateGlobalLogger "borel" (setLevel DEBUG)++ params <- ask+ (outputWork, inputWork, sealWork) <- liftIO . spawn' $ bounded 1+ (outputRes, inputRes, sealRes) <- liftIO . spawn' $ bounded 1+ let grouped = groupMetrics+ ( params ^. paramBorelConfig . allInstances)+ ( params ^. paramMetrics)+ defaultFilters = Filters billableStatus+ producer+ :: (MonadIO m, MonadSafe m)+ => Producer (GroupedMetric, Origin, Address, SourceDict) m ()+ producer = P.enumerate+ [ (metrics, org, addr, sd)+ | metrics <- Select $ P.each grouped+ , (org, addr, sd) <- Select $ chevalier params (metrics, params ^. paramTID)+ ]+ worker+ :: (MonadIO m, MonadSafe m)+ => Pipe (GroupedMetric, Origin, Address, SourceDict)+ (Metric, ResponseItem)+ m+ ()+ worker = forever $ do+ let flavors = params ^. paramBorelConfig . paramFlavorMap+ start = params ^. paramStart+ end = params ^. paramEnd++ (metrics, org, addr, sd) <- await+ results <- ceilometer flavors metrics+ (Env flavors sd defaultFilters start end)+ (marquise params (metrics, org, addr))+ forM_ results $ \result -> yield (fst result, mkItem sd result)++ -- This hierarchy is necessary to close the buffers in case of an error.+ pollWorkers <- liftIO . async $ (do+ workers <- replicateM 8 . async . runSafeT . runEffect $+ fromInput inputWork >-> worker >-> toOutput outputRes+ mapM_ link workers+ mapM_ wait workers) `E.finally` (atomically $ sealWork >> sealRes)+ liftIO $ link pollWorkers++ pollProducer <- liftIO . async $+ (runSafeT . runEffect $ producer >-> toOutput outputWork)+ `E.finally` atomically sealWork+ liftIO $ link pollProducer++ fromInput inputRes++ liftIO $ wait pollProducer+ liftIO . atomically $ sealRes+ liftIO $ wait pollWorkers
+ lib/Borel/Ceilometer.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE TupleSections #-}++module Borel.Ceilometer+ ( ceilometer+ , module Borel.Ceilometer.Instance+ )+where++import Control.Applicative+import Control.Monad.Reader+import qualified Data.Bimap as BM+import qualified Data.List as L+import qualified Data.Map as M+import Data.Maybe+import Data.Monoid+import Pipes hiding (Proxy)+import System.Log.Logger++-- friends+import Ceilometer.Client+import Vaultaire.Types++import Borel.Ceilometer.Instance+import Borel.Types+++--------------------------------------------------------------------------------++-- | Use Ceilometer to decode and aggregate a stream of raw data points.+--+ceilometer+ :: (MonadIO m, Applicative m)+ => FlavorMap -- ^ Instance flavor mapping+ -> GroupedMetric -- ^ Requested metrics, this determines how we present the fold result+ -> Env -- ^ Ceilometer arguments+ -> Producer SimplePoint m () -- ^ Raw points+ -> m [Result]+ceilometer flavors metrics cenv@(Env _ sd _ _ _) raw = do+ liftIO $ debugM "borel" ("using ceilometer to decode data with " <> show sd)+ fromMaybe [] <$> fmap handleResult <$> decodeFold cenv raw++ where handleResult :: FoldResult -> [Result]+ handleResult x = case (x, metrics) of+ (RSingle val, [m]) -> [(m,val)]+ (RMapNum32 vals, [m]) -> [(m, M.foldlWithKey (\a k v -> a + (fromIntegral k * v)) 0 vals)]+ (RMapNum64 vals, [m]) -> [(m, M.foldlWithKey (\a k v -> a + (fromIntegral k * v)) 0 vals)]+ (RMapText vals, _) -> let ms = intersect metrics flavors+ in map (\(metric, flavor) -> (metric,) $ fromMaybe 0 $ M.lookup flavor vals) ms+ _ -> []++ -- Intersect the flavor map and the list of metrics requested. Flatten the result.+ intersect :: [Metric] -> FlavorMap -> [(Metric, Flavor)]+ intersect ms = BM.fold (\k1 _ acc -> maybe acc ((:acc) . (,k1))+ $ L.find (== mkInstance k1) ms) []
+ lib/Borel/Ceilometer/Instance.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE TupleSections #-}++module Borel.Ceilometer.Instance where++import Ceilometer.Types++billableStatus :: PFInstanceStatus -> Bool+billableStatus InstanceError = False+billableStatus InstanceActive = True+billableStatus InstanceShutoff = False+billableStatus InstanceBuild = False+billableStatus InstanceRebuild = False+billableStatus InstanceDeleted = False+billableStatus InstanceSoftDeleted = False+billableStatus InstanceShelved = False+billableStatus InstanceShelvedOffloaded = False+billableStatus InstanceReboot = True+billableStatus InstanceHardReboot = True+billableStatus InstancePassword = True+billableStatus InstanceResize = True+billableStatus InstanceVerifyResize = True+billableStatus InstanceRevertResize = True+billableStatus InstancePaused = False+billableStatus InstanceSuspended = False+billableStatus InstanceRescue = False+billableStatus InstanceMigrating = True
+ lib/Borel/Chevalier.hs view
@@ -0,0 +1,128 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE MonadComprehensions #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ViewPatterns #-}++module Borel.Chevalier+ ( chevalier )+where++import Control.Lens ((^.))+import Control.Monad.Reader+import Data.Either+import Data.Monoid+import Data.Set (Set)+import qualified Data.Set as S+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as E+import Network.URI+import Pipes as P+import Pipes.Safe as P+import System.Log.Logger+import qualified System.ZMQ4 as Z++import Ceilometer.Tags+import qualified Chevalier.Types as C+import qualified Chevalier.Util as C+import Vaultaire.Types++import Borel.Types+++-- | Use Chevalier to find origin, address, sourcedict that contains data relevant+-- to this OpenStack tenancy.+--+chevalier :: (MonadIO m, MonadSafe m)+ => BorelEnv+ -> (GroupedMetric, TenancyID)+ -> Producer (Origin, Address, SourceDict) m ()+chevalier params (metrics, tid) = do+ let tags = chevalierTags+ (params ^. paramBorelConfig . allInstances)+ (metrics, tid)+ when (null tags) $ return ()+ liftIO $ debugM "borel" ("searching chevalier with tags=" <> show tags)++ P.enumerate+ [ (org, addr, sd)+ | org <- Select $ P.each (params ^. paramBorelConfig . paramOrigins)+ , (addr, sd) <- Select $ searchP+ (params ^. paramBorelConfig . paramZMQContext)+ (params ^. paramBorelConfig . paramChevalierURI)+ org+ (C.buildRequestFromPairs tags)+ ]++-- | Converts a GroupedMetric and a TenancyID into a list of cheavlier tags+-- Also requires a set of the currently configured instance flavors+chevalierTags :: Set Metric -> (GroupedMetric, TenancyID) -> [(Text, Text)]+chevalierTags instances (ms, TenancyID tid) = case ms of+ [metric] -> if+ | metric == cpu -> [tagID tid , tagName "cpu" ]+ | metric == block -> [tagID tid , tagName "volume.size", tagBlock , tagEvent ]+ | metric == ssd -> [tagID tid , tagName "volume.size", tagFast , tagEvent ]+ | metric == diskReads -> [tagID tid , tagName "disk.read.bytes" ]+ | metric == diskWrites -> [tagID tid , tagName "disk.write.bytes" ]+ | metric == neutronIn -> [tagID tid , tagName "network.incoming.bytes" ]+ | metric == neutronOut -> [tagID tid , tagName "network.outgoing.bytes" ]+ | metric == ipv4 -> [tagID tid , tagName "ip.floating" , tagEvent ]+ | metric == vcpus -> [tagID tid , tagName "instance_vcpus" , tagPollster ]+ | metric == memory -> [tagID tid , tagName "instance_ram" , tagPollster ]+ | metric == snapshot -> [tagID tid , tagName "snapshot.size" , tagEvent ]+ | metric == image -> [tagID tid , tagName "image.size" , tagPollster ]+ | otherwise -> []+ _ -> if+ | all (`S.member` instances) ms+ -> [tagID tid , tagName "instance_flavor" , tagPollster ]+ | otherwise -> []+ where tagID = (keyTenancyID,)+ tagName = (keyMetricName,)+ tagEvent = (keyEvent, valTrue)+ tagPollster = (keyEvent, valFalse)+ tagBlock = (keyVolumeType, valVolumeBlock)+ tagFast = (keyVolumeType, valVolumeFast)+++--------------------------------------------------------------------------------++searchP+ :: (MonadIO m)+ => Z.Context -> URI+ -> Origin -> C.SourceRequest+ -> Producer (Address, SourceDict) m ()+searchP ctx uri org req = do+ x <- lift $ search ctx uri org req+ liftIO $ debugM "borel" ("addresses=" <> show (map fst x))+ P.each x++-- this doesn't stream because chevalier doesn't+search+ :: (MonadIO m)+ => Z.Context -> URI+ -> Origin -> C.SourceRequest+ -> m [(Address, SourceDict)]+search ctx uri origin request+ = liftIO+ $ runChevalier ctx uri+ $ \conn -> liftIO $ do+ resp <- liftIO (sendrecv conn)+ return $ either (error . show) (rights . map C.convertSource) (C.decodeResponse resp)+ where sendrecv sock = do+ Z.send sock [Z.SendMore] $ encodeOrigin origin+ Z.send sock [] $ C.encodeRequest request+ Z.receive sock+ encodeOrigin (Origin x) = E.encodeUtf8 $ T.pack $ show x++type Chevalier = Z.Socket Z.Req++runChevalier+ :: Z.Context -> URI+ -> (Chevalier -> IO x)+ -> IO x+runChevalier ctx (show -> uri) act+ = Z.withSocket ctx Z.Req $ \sock -> do+ Z.connect sock uri+ act sock
+ lib/Borel/Error.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE OverloadedStrings #-}+-- | Copyright 2014-2015 Anchor Systems, Pty Ltd and Others+--+-- The code in this file, and the program it is a part of, is+-- made available to you by its authors as open source software:+-- you can redistribute it and/or modify it under the terms of+-- the 3-clause BSD licence.+--+-- /Description/+-- This module defines error types in Borel.+--+-- Because Borel provides a safe pipeline to process data from+-- Marquise, we cannot insert abitrary exit points with Except/Error.+-- (e.g. `Producer x (ExceptT BorelError m) r` is not possible because+-- `m` is required to be a `MonadSafe` so that resources can be+-- cleaned up after a failure in the stream.)+--+-- Instead Borel errors need to be handled inside the pipeline. We can+-- choose to stop streaming or log the error.+--+module Borel.Error+ ( BorelError(..)+ , lookupSD+ , noteBorelError+ , stopBorelError+ ) where++import Control.Error.Util+import Control.Monad+import Control.Monad.IO.Class+import Data.Monoid+import Data.Text (Text)+import Pipes++import Vaultaire.Types++type Message = Text++data BorelError+ = SourceDictLookup SourceDict Message+ | ConfigLoad Message+ deriving (Eq, Show)++lookupSD :: Text -> SourceDict -> Either BorelError Text+lookupSD key sd+ = note (SourceDictLookup sd $ "lookup failed: with key=" <> key)+ (lookupSource key sd)++noteBorelError :: MonadIO m => Pipe (Either BorelError a) a m r+noteBorelError = forever $ await >>= either (const (return ()) . show) yield++stopBorelError :: Either BorelError x -> x+stopBorelError (Left e) = error $ "implode" <> show e+stopBorelError (Right x) = x
+ lib/Borel/Marquise.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MonadComprehensions #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ViewPatterns #-}++module Borel.Marquise+ ( marquise )++where++import Control.Lens+import Control.Monad+import Data.Monoid+import Network.URI+import Pipes+import Pipes.Safe as P+import System.Log.Logger+import qualified System.ZMQ4 as Z++-- friends+import qualified Marquise.Client as M+import Vaultaire.Types++-- family+import Borel.Types+++-- | Use Marquise to fetch raw data points.+--+marquise :: (MonadIO m, MonadSafe m)+ => BorelEnv+ -> (GroupedMetric, Origin, Address)+ -> Producer SimplePoint m ()+marquise params (metrics, origin, addr) = do+ liftIO $ debugM "borel" ("fetching from marquise with origin="+ <> show origin+ <> " addr="+ <> show addr)++ case metrics of+ [metric] -> if+ | metric == block -> events+ | metric == ssd -> events+ | metric == ipv4 -> events+ | metric == snapshot -> events+ | otherwise -> points+ _ -> points+ where events = rangeData context uri origin addr (TimeStamp 0) end+ points = rangeData context uri origin addr (params ^. paramStart) end+ context = params ^. paramBorelConfig . paramZMQContext+ uri = params ^. paramBorelConfig . paramMarquiseURI+ end = params ^. paramEnd++rangeData+ :: (MonadIO m, MonadSafe m)+ => Z.Context -> URI+ -> Origin -> Address -> TimeStamp -> TimeStamp+ -> Producer SimplePoint m ()+rangeData ctx uri origin addr start end+ = runMarquiseReader ctx uri+ $ \conn -> hoist liftIO+ $ void (M.readSimplePoints addr start end origin conn)++--------------------------------------------------------------------------------++-- Marquise runners wrap marquise functionalities in a composable, safe pipe.++type MarquiseReader = M.SocketState++runMarquiseReader+ :: (MonadSafe m)+ => Z.Context -> URI+ -> (MarquiseReader -> Proxy a a' b b' m x)+ -> Proxy a a' b b' m x+runMarquiseReader ctx (show -> uri) f+ = P.bracket (liftIO $ Z.socket ctx Z.Dealer) (liftIO . Z.close) $ \sock ->+ P.bracket (liftIO $ Z.connect sock uri) (const $ return ())$ \_ ->+ f (M.SocketState sock uri)
+ lib/Borel/Types.hs view
@@ -0,0 +1,233 @@+-- | Copyright 2014-2015 Anchor Systems, Pty Ltd and Others+--+-- The code in this file, and the program it is a part of, is+-- made available to you by its authors as open source software:+-- you can redistribute it and/or modify it under the terms of+-- the 3-clause BSD licence.+--+-- /Description/+-- This module defines user-facing types and environment for+-- Borel requests.+--+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}++-- for configuration+{-# OPTIONS -fno-warn-orphans #-}++module Borel.Types+ ( -- * BorelConfig+ BorelConfig(..)+ , mkBorelConfig, parseBorelConfig, loadBorelConfig+ , allInstances, allMetrics+ , paramBorelConfig+ , paramFlavorMap+ , paramOrigins+ , paramMarquiseURI, paramChevalierURI+ , paramZMQContext++ -- * Query arguments+ , BorelEnv+ , TenancyID(..)+ , GroupedMetric+ , paramStart, paramEnd, paramMetrics, paramTID++ -- * Running+ , BorelS+ , runBorel+ , defaultStart, defaultEnd++ -- * Re-exports+ , module X+ ) where++import Control.Applicative+import Control.Concurrent (ThreadId)+import Control.Error.Util+import Control.Lens (makeLenses, mapped, over, _2)+import Control.Monad.Reader+import Data.Aeson+import qualified Data.Bimap as BM+import qualified Data.Configurator as C+import qualified Data.Configurator.Types as C+import qualified Data.HashMap.Strict as HM+import qualified Data.List as L+import Data.Maybe+import Data.Monoid+import Data.Set (Set)+import qualified Data.Set as S+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Data.Time.Clock+import Data.Time.Clock.POSIX+import qualified Data.Traversable as T+import Network.URI+import Pipes+import Pipes.Lift+import Pipes.Safe+import qualified System.ZMQ4 as Z++import Ceilometer.Types+import Marquise.Types+import Vaultaire.Types++import Borel.Error as X+import Borel.Types.Metric as X+import Borel.Types.Result as X+import Borel.Types.UOM as X++++type GroupedMetric = [Metric]++--------------------------------------------------------------------------------++newtype TenancyID = TenancyID { _tenancyID :: Text }+ deriving (Eq)++instance Show TenancyID where+ show = show . _tenancyID++instance ToJSON TenancyID where+ toJSON (TenancyID x) = object [ "tenancy-id" .= x ]++instance Read TenancyID where+ readsPrec _ = maybe [] (pure . (,"")) . Just . TenancyID . T.pack++--------------------------------------------------------------------------------++-- | BorelConfigure Borel globals that persist across many queries.+-- (can be reloaded).+--+data BorelConfig = BorelConfig+ { _paramOrigins :: Set Origin+ , _paramZMQContext :: Z.Context+ , _paramMarquiseURI :: URI+ , _paramChevalierURI :: URI+ , _paramFlavorMap :: FlavorMap+ , _allInstances :: Set Metric+ , _allMetrics :: Set Metric }++makeLenses ''BorelConfig++mkBorelConfig :: Set Origin -> Z.Context -> URI -> URI -> FlavorMap -> BorelConfig+mkBorelConfig org ctx marq chev fm+ = BorelConfig org ctx marq chev fm (S.fromList fs) (S.fromList ms)+ where ms :: [Metric]+ ms = fs <>+ [ diskReads, diskWrites+ , neutronIn, neutronOut+ , cpu, vcpus, memory, ipv4, block, ssd+ , snapshot, image+ ]+ fs :: [Metric]+ fs = map mkInstance (BM.keys fm)++parseBorelConfig :: C.Config -> IO (Either BorelError BorelConfig)+parseBorelConfig raw = do+ flavors <- enumFlavors raw+ context <- Z.context++ liftM5 mkBorelConfig+ <$> (note (ConfigLoad "cannot read list of origins") <$> C.lookup raw nameOrigins)+ <*> return (Right context)+ <*> (note (ConfigLoad "cannot read Marquise URI") <$> C.lookup raw nameMarquise)+ <*> (note (ConfigLoad "cannot read Chevalier URI") <$> C.lookup raw nameChevalier)+ <*> (note (ConfigLoad "cannot read flavors") <$> (fmap mkFM . T.sequenceA <$> mapM lookupFlavor flavors))++ where nameOrigins = "origins"+ nameMarquise = "marquise-reader-uri"+ nameChevalier = "chevalier-uri"+ nameFlavorGroup = "flavors."++ lookupFlavor :: C.Name -> IO (Maybe (Text, Text))+ lookupFlavor name+ = fmap (name,)+ <$> C.lookup raw (nameFlavorGroup <> name <> ".id")++ mkFM :: [(Text, Text)] -> FlavorMap+ mkFM = BM.fromList . over (mapped._2) siphashID++ enumFlavors conf = do+ m <- C.getMap conf+ return+ $ L.nub+ $ map (T.takeWhile (/= '.') . fromMaybe "" . T.stripPrefix nameFlavorGroup)+ $ HM.keys+ $ HM.filterWithKey (\k _ -> nameFlavorGroup `T.isPrefixOf` k) m+++loadBorelConfig :: FilePath -> IO (Either BorelError (BorelConfig, ThreadId))+loadBorelConfig filepath = do+ -- TODO add handler for config loading failure+ (raw, t) <- C.autoReload C.autoConfig [C.Required filepath]+ conf <- parseBorelConfig raw+ return $ (,t) <$> conf++instance C.Configured Origin where+ convert (C.String s) = hush $ makeOrigin $ T.encodeUtf8 s+ convert _ = Nothing++instance C.Configured (Set Origin) where+ convert (C.List xs) = S.fromList <$> T.mapM C.convert xs+ convert _ = Nothing++instance C.Configured URI where+ convert (C.String s) = parseURI (T.unpack s)+ convert _ = Nothing+++--------------------------------------------------------------------------------++-- | Parameters for a Borel request+--+data BorelEnv = BorelEnv+ { _paramBorelConfig :: BorelConfig+ , _paramMetrics :: Set Metric+ , _paramTID :: TenancyID+ , _paramStart :: TimeStamp+ , _paramEnd :: TimeStamp+ }++makeLenses ''BorelEnv++defaultStart :: IO TimeStamp+defaultStart = liftM (addTimeStamp ((-7) * posixDayLength)) getCurrentTimeNanoseconds+ where addTimeStamp x a = convertToTimeStamp+ $ addUTCTime (convertToDiffTime a) (posixSecondsToUTCTime x)++defaultEnd :: IO TimeStamp+defaultEnd = getCurrentTimeNanoseconds+++--------------------------------------------------------------------------------++newtype BorelS m a = BorelS { borelM :: ReaderT BorelEnv m a }+ deriving ( Functor, Applicative, Monad+ , MonadTrans, MonadIO+ , MonadThrow, MonadMask, MonadCatch+ , MonadReader BorelEnv )++instance MonadSafe m => MonadSafe (BorelS m) where+ type Base (BorelS m) = Base m+ liftBase = lift . liftBase+ register = lift . register+ release = lift . release++runBorel :: Monad m+ => BorelConfig+ -> Set Metric+ -> TenancyID+ -> TimeStamp+ -> TimeStamp+ -> Producer x (BorelS m) ()+ -> Producer x m ()+runBorel conf ms t s e p = runReaderP (BorelEnv conf ms t s e)+ $ hoist borelM p
+ lib/Borel/Types/Metric.hs view
@@ -0,0 +1,117 @@+-- | Copyright 2014-2015 Anchor Systems, Pty Ltd and Others+--+-- The code in this file, and the program it is a part of, is+-- made available to you by its authors as open source software:+-- you can redistribute it and/or modify it under the terms of+-- the 3-clause BSD licence.+--+-- /Description/+-- This module defines user-facing query-able metrics,+-- which can correspond to one or many Ceilometer resources.+--++{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}++{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++module Borel.Types.Metric+ ( -- * Metric+ Metric(..)+ , cpu, block, ssd, diskReads, diskWrites, neutronIn, neutronOut+ , ipv4, vcpus, memory, snapshot, image+ , mkInstance+ ) where++import Data.Monoid+import Data.Text (Text)++import Borel.Types.UOM+import Ceilometer.Types+++data Metric = Metric+ { deserialise :: Text -- ^ what it parses from+ , pretty :: Text -- ^ what it pretty prints to+ , uom :: UOM+ } deriving (Eq, Ord, Show)++mkInstance :: Flavor -> Metric+mkInstance name = Metric+ { deserialise = "instances-" <> name+ , pretty = "instance-" <> name <> "-allocation"+ , uom = countInstance `Times` nanosec+ }++cpu = Metric+ { deserialise = "cpu"+ , pretty = "cpu-usage"+ , uom = countCPU `Times` nanosec+ }++diskReads = Metric+ { deserialise = "diskio/reads"+ , pretty = "diskio-reads"+ , uom = byte+ }++diskWrites = Metric+ { deserialise = "diskio/writes"+ , pretty = "diskio-writes"+ , uom = byte+ }++neutronIn = Metric+ { deserialise = "neutron-traffic-incoming"+ , pretty = "neutron-data-rx"+ , uom = byte+ }++neutronOut = Metric+ { deserialise = "neutron-traffic-outgoing"+ , pretty = "neutron-data-tx"+ , uom = byte+ }++ipv4 = Metric+ { deserialise = "ipv4-addresses"+ , pretty = "floating-ip-allocation"+ , uom = countIP `Times` nanosec+ }++block = Metric+ { deserialise = "volumes-block"+ , pretty = "volume-block-allocation"+ , uom = gigabyte `Times` nanosec+ }++ssd = Metric+ { deserialise = "volumes-fast"+ , pretty = "volume-fast-allocation"+ , uom = gigabyte `Times` nanosec+ }++vcpus = Metric+ { deserialise = "vcpus"+ , pretty = "vcpu-allocation"+ , uom = countVCPU `Times` nanosec+ }++memory = Metric+ { deserialise = "memory"+ , pretty = "memory-allocation"+ , uom = megabyte `Times` nanosec+ }++snapshot = Metric+ { deserialise = "snapshot"+ , pretty = "snapshot"+ , uom = gigabyte `Times` nanosec+ }++image = Metric+ { deserialise = "image"+ , pretty = "image"+ , uom = byte `Times` nanosec+ }
+ lib/Borel/Types/Result.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++-- | Copyright 2014-2015 Anchor Systems, Pty Ltd and Others+--+-- The code in this file, and the program it is a part of, is+-- made available to you by its authors as open source software:+-- you can redistribute it and/or modify it under the terms of+-- the 3-clause BSD licence.+--+-- /Description/+-- This module defines the Result type and how it's presented.+--+module Borel.Types.Result+ ( -- * Query results+ Result+ , ResponseItem(..)+ , respResource, respResourceID, respVal+ , mkItem++ -- * Convenient+ , uomVal+ ) where++import Control.Applicative+import Control.Lens hiding ((.=))+import Control.Monad+import Data.Aeson hiding (Result)+import Data.Csv (FromRecord, ToRecord, parseRecord, record,+ toField, toRecord, (.!))+import Data.Text (Text)+import qualified Data.Vector as V+import Data.Word++import Ceilometer.Tags+import Vaultaire.Types++import Borel.Error+import Borel.Types.Metric+import Borel.Types.UOM++type Result = (Metric, Word64)+type Val = (UOM, Word64)++data ResponseItem = ResponseItem+ { _respResource :: Text+ , _respResourceID :: Text+ , _respVal :: Val }+ deriving (Eq, Show, Read)++makeLenses ''ResponseItem++instance FromJSON ResponseItem where+ parseJSON (Object x)+ = ResponseItem+ <$> x .: "resource"+ <*> x .: "resource-id"+ <*> ((,) <$> x .: "uom"+ <*> x .: "quantity")+ parseJSON _ = mzero++instance ToJSON ResponseItem where+ toJSON (ResponseItem n i (u,x))+ = object [ "resource" .= n+ , "resource-id" .= i+ , "uom" .= u+ , "quantity" .= x ]++instance FromRecord ResponseItem where+ parseRecord v+ | V.length v == 4 = ResponseItem+ <$> v .! 0+ <*> v .! 1+ <*> ((,) <$> v .! 2+ <*> v .! 3)++ | otherwise = mzero++instance ToRecord ResponseItem where+ toRecord (ResponseItem n i (u,v))+ = record [ toField n+ , toField i+ , toField u+ , toField v ]++mkItem :: SourceDict -> Result -> ResponseItem+mkItem sd (metric, quantity)+ = let name = pretty metric+ uid = stopBorelError $ lookupSD keyResourceID sd+ in ResponseItem name uid (uom metric, quantity)++-- Some convenient traversals++uomVal :: Lens' ResponseItem Val+uomVal f (ResponseItem x y v)+ = ResponseItem x y <$> f v
+ lib/Borel/Types/UOM.hs view
@@ -0,0 +1,264 @@+-- | Copyright 2013-2015 Anchor Systems, Pty Ltd and Others+--+-- The code in this file, and the program it is a part of, is+-- made available to you by its authors as open source software:+-- you can redistribute it and/or modify it under the terms of+-- the 3-clause BSD licence.+--+-- /Description/+-- This module defines unit of measurement for metric reports.+--++{-# OPTIONS -fno-warn-missing-signatures #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ViewPatterns #-}++module Borel.Types.UOM+ ( -- * Unit of measurement+ UOM(..), BaseUOM(..), Prefix(..)++ -- * Convenient constructors+ , sec, nanosec, byte, megabyte, gigabyte+ , countCPU, countVCPU, countInstance, countIP++ -- * Conversions+ , convert, tryConvert+ , nanosecToSec, byteToGigabyte, nanosecToHour++ -- * Utilities+ , pUOM, pPrefixUOM, pBaseUOM+ , flattenUOM, mapUOM++ ) where++import Control.Applicative+import Control.Error.Util+import Control.Lens (Prism', preview, prism', re, review,+ (^.), (^?))+import Control.Monad+import Data.Aeson+import qualified Data.Attoparsec.Text as AT+import Data.Csv (FromField, ToField, parseField, toField)+import Data.Maybe+import Data.Monoid+import Data.MultiSet (MultiSet)+import qualified Data.MultiSet as S+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as E+import Data.Word+++--------------------------------------------------------------------------------++-- * Our UOM parser is only total for UOMs made up of+-- these components. This is because the format we need+-- to work with is restrictive.++countCPU = UOM Base CPU+countVCPU = UOM Base VCPU+countInstance = UOM Base Instance+countIP = UOM Base IPAddress+nanosec = UOM Nano Second+sec = UOM Base Second+byte = UOM Base Byte+megabyte = UOM Mega Byte+gigabyte = UOM Giga Byte+hour = UOM Base Hour+++--------------------------------------------------------------------------------++data UOM+ = UOM Prefix BaseUOM+ | Times UOM UOM+ deriving (Eq, Ord)++data Prefix+ = Base+ | Giga+ | Nano+ | Mebi+ | Mega+ deriving (Eq, Ord, Enum, Bounded)++data BaseUOM+ = Second+ | Hour+ | Byte+ | Instance+ | IPAddress+ | CPU+ | VCPU+ deriving (Eq, Ord, Enum, Bounded)++pBaseUOM :: Prism' Text BaseUOM+pBaseUOM = prism' pretty parse+ where pretty Second = "s"+ pretty Hour = "h"+ pretty Byte = "B"+ pretty Instance = "instance"+ pretty IPAddress = "ip"+ pretty CPU = "cpu"+ pretty VCPU = "vcpu"+ parse "s" = Just Second+ parse "h" = Just Hour+ parse "B" = Just Byte+ parse "instance" = Just Instance+ parse "ip" = Just IPAddress+ parse "cpu" = Just CPU+ parse "vcpu" = Just VCPU+ parse _ = Nothing++pPrefixUOM :: Prism' Text Prefix+pPrefixUOM = prism' pretty parse+ where pretty Base = ""+ pretty Giga = "G"+ pretty Nano = "n"+ pretty Mebi = "Mi"+ pretty Mega = "M"+ parse "" = Just Base+ parse "G" = Just Giga+ parse "n" = Just Nano+ parse "Mi" = Just Mebi+ parse "M" = Just Mega+ parse _ = Nothing++pUOM :: Prism' Text UOM+pUOM = prism' pretty parse+ where dash = "-"+ pretty (u `Times` v) = (u ^. re pUOM) <> dash <> (v ^. re pUOM)+ pretty (UOM p b) = (p ^. re pPrefixUOM) <> (b ^. re pBaseUOM)++ -- treat UOM @Times@ as left-associative.+ parse = hush . AT.parseOnly (parser <* AT.endOfInput)+ parser = do+ uoms <- puom `AT.sepBy` AT.string dash+ case uoms of [] -> mzero+ -- construct left-associative UOMs+ (u:us) -> return $ foldl Times u us+ puom = do+ pre <- AT.option (Just Base) ppre+ base <- pbase+ case (pre, base) of (Just p, Just b) -> return $ UOM p b+ _ -> mzero+ ppre = (preview pPrefixUOM <$> AT.string "G")+ <|> (preview pPrefixUOM <$> AT.string "n")+ <|> (preview pPrefixUOM <$> AT.string "Mi")+ <|> (preview pPrefixUOM <$> AT.string "M")+ pbase = (preview pBaseUOM <$> AT.string "s")+ <|> (preview pBaseUOM <$> AT.string "h")+ <|> (preview pBaseUOM <$> AT.string "B")+ <|> (preview pBaseUOM <$> AT.string "instance")+ <|> (preview pBaseUOM <$> AT.string "ip" )+ <|> (preview pBaseUOM <$> AT.string "cpu")+ <|> (preview pBaseUOM <$> AT.string "vcpu")++instance Show BaseUOM where+ show = T.unpack . review pBaseUOM++instance Show Prefix where+ show = T.unpack . review pPrefixUOM++instance Show UOM where+ show = T.unpack . review pUOM++instance Read UOM where+ readsPrec _ (T.pack -> x) = maybe [] (pure . (,"")) $ x ^? pUOM++instance FromJSON UOM where+ parseJSON (String t) = maybe mzero return $ t ^? pUOM+ parseJSON _ = mzero++instance ToJSON UOM where+ toJSON x = String $ x ^. re pUOM++instance FromField UOM where+ parseField (E.decodeUtf8 -> t) = maybe mzero return $ t ^? pUOM++instance ToField UOM where+ toField x = E.encodeUtf8 $ x ^. re pUOM++--------------------------------------------------------------------------------++nanosecToSec :: (UOM, Word64) -> (UOM, Word64)+nanosecToSec (old, v)+ = let new = mapUOM f old+ in (new, tryConvert old new v)+ where f p b | UOM p b == nanosec = sec+ | otherwise = UOM p b++byteToGigabyte :: (UOM, Word64) -> (UOM, Word64)+byteToGigabyte (old, v)+ = let new = mapUOM f old+ in (new, tryConvert old new v)+ where f p b | UOM p b == byte = gigabyte+ | otherwise = UOM p b++nanosecToHour :: (UOM, Word64) -> (UOM, Word64)+nanosecToHour (old,v)+ = let new = mapUOM f old+ in (new, tryConvert old new v)+ where f p b | UOM p b == nanosec = hour+ | otherwise = UOM p b++-- Not a functor.+mapUOM :: (Prefix -> BaseUOM -> UOM) -> UOM -> UOM+mapUOM f (UOM p b) = f p b+mapUOM f (Times x y) = Times (mapUOM f x) (mapUOM f y)++flattenUOM :: UOM -> [UOM]+flattenUOM x@(UOM _ _) = [x]+flattenUOM (Times x y) = flattenUOM x ++ flattenUOM y++class Weighed a where+ weigh :: a -> Double++instance Weighed Prefix where+ weigh Base = 1+ weigh Giga = 10^^(9 :: Int)+ weigh Nano = 10^^(-9 :: Int)+ weigh Mebi = 1024^^(2 :: Int)+ weigh Mega = 10^^(6 :: Int)++instance Weighed BaseUOM where+ weigh Hour = 60 * 60+ weigh _ = 1++instance Weighed UOM where+ weigh (UOM p b) = weigh p * weigh b+ weigh (a `Times` b) = weigh a * weigh b++data Dimension+ = CTime+ | CData+ | CInstance+ | CIPAddress+ | CCPU+ | CVCPU+ deriving (Eq, Ord)++dimension :: BaseUOM -> Dimension+dimension Second = CTime+dimension Hour = CTime+dimension Byte = CData+dimension Instance = CInstance+dimension IPAddress = CIPAddress+dimension CPU = CCPU+dimension VCPU = CVCPU++dimensions :: UOM -> MultiSet Dimension+dimensions (UOM _ b) = S.singleton $ dimension b+dimensions (a `Times` b) = dimensions a <> dimensions b++convert :: UOM -> UOM -> Maybe (Word64 -> Word64)+convert old new+ | dimensions old == dimensions new+ = let factor = weigh old / weigh new+ in Just (floor . (*) (toRational factor) . toRational)+ | otherwise = Nothing++tryConvert :: UOM -> UOM -> Word64 -> Word64+tryConvert old new = fromMaybe id $ convert old new+
+ tests/Main.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+import Control.Applicative+import Control.Lens hiding (elements)+import Control.Lens.Properties+import Control.Monad+import qualified Data.Aeson as A+import qualified Data.Bimap as BM+import Data.Configurator+import Data.Either.Combinators+import qualified Data.List as L+import Data.Maybe+import Data.Monoid+import qualified Data.Set as S+import qualified Data.Text as T+import Data.Word+import Network.URI+import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck+import Test.QuickCheck.Function++import Borel+import Borel.Types+import Borel.Types.Result+import Borel.Types.UOM+import Vaultaire.Types++import Debug.Trace++main :: IO ()+main = do+ hspec uomTest+ hspec confTest+ hspec respTest++uomTest :: Spec+uomTest = do++ describe "UOM conversion" $+ prop "converts nanosec to sec" $ property $ do+ uom <- uomNoNanosec+ return $ trace ("uom=" ++ show uom ) $ nanosecToSec (uom `Times` nanosec, 1000000000) == (uom `Times` sec, 1)++ describe "UOM pretty-printing" $ do+ it "as expected for basic UOMs"+ $ show uom0 `shouldBe` uomResult0+ it "as expected for compound UOMS"+ $ show uom1 `shouldBe` uomResult1++ describe "UOM parsing" $ do+ it "as expected for basic UOMs"+ $ (read uomResult0 :: UOM) `shouldBe` uom0+ it "as expected for compound UOMs"+ $ (read uomResult1 :: UOM) `shouldBe` uom1++confTest :: Spec+confTest =+ describe "Configuration parser" $+ it "parses the sample config" $ do+ c <- join $ parseBorelConfig <$> load [Required "tests/sample.conf"]+ c `shouldBe` Right sampleConf+++respTest :: Spec+respTest = do+ describe "Response Item" $+ it "has a valid lens for (UOM, Value)" $ isLens uomVal++ describe "Response Item JSON" $+ prop "x == decode (encode x)" $ property $ do+ x <- arbitrary :: Gen ResponseItem+ return $ Just x == A.decode (A.encode x)++--------------------------------------------------------------------------------++uom0 = UOM Base Second+uomResult0 = "s"++uom1 = UOM Base Instance `Times` UOM Nano Second `Times` UOM Giga Byte+uomResult1 = "instance-ns-GB"++sampleConf :: BorelConfig+sampleConf =+ (mkBorelConfig (S.singleton $ fromRight' $ makeOrigin "ABCDEF")+ undefined+ (fromJust $ parseURI "tcp://example.com:999")+ (fromJust $ parseURI "tcp://nsa.gov:3333")+ (BM.fromList [("asio", 2866838636), ("koolaid", 944337339)]))++--------------------------------------------------------------------------------++instance Function UOM where function = functionShow+instance Function Word64 where function = functionShow+instance Function ResponseItem where function = functionShow++instance Arbitrary Prefix where arbitrary = arbitraryBoundedEnum+instance Arbitrary BaseUOM where arbitrary = arbitraryBoundedEnum+instance Arbitrary UOM where arbitrary = sized someUOMs+instance Arbitrary ResponseItem where+ arbitrary = ResponseItem "" ""+ <$> ((,) <$> arbitrary <*> arbitrary)++instance CoArbitrary UOM where+ coarbitrary = variant . length . flattenUOM++instance CoArbitrary ResponseItem where+ coarbitrary (ResponseItem _ _ (u,v))+ = variant (length $ flattenUOM u)+ . variant v++-- Our print/parse UOM is only total for UOMs made up of+-- these UOMs.+supportedUOMs :: Gen UOM+supportedUOMs+ = elements+ [ sec, nanosec, byte, megabyte, gigabyte+ , countCPU, countVCPU, countInstance, countIP ]++someUOMs :: Int -> Gen UOM+someUOMs 0 = supportedUOMs+someUOMs n = do+ Positive m <- arbitrary `suchThat` ((<)n . getPositive)+ Positive p <- arbitrary `suchThat` ((<)n . getPositive)+ let x = n `div` m+ y = n `div` p+ left <- someUOMs x+ right <- someUOMs y+ return (Times left right)++uomNoNanosec :: Gen UOM+uomNoNanosec = arbitrary `suchThat` (not . any (== nanosec) . flattenUOM)++-- orphan instances for testing only, they don't make sense as actual uses.++instance Show BorelConfig where+ show (BorelConfig o _ u1 u2 fm ins ms)+ = "config:("+ <> show o <> ","+ <> show u1 <> ","+ <> show u2 <> ","+ <> show fm <> ","+ <> show ins <> ","+ <> show ms <> ","+ <> ")"++instance Eq BorelConfig where+ (==) x y = show x == show y