diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/borel.cabal b/borel.cabal new file mode 100644 --- /dev/null +++ b/borel.cabal @@ -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 +maintainer: Anchor Engineering +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 + diff --git a/lib/Borel.hs b/lib/Borel.hs new file mode 100644 --- /dev/null +++ b/lib/Borel.hs @@ -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 diff --git a/lib/Borel/Ceilometer.hs b/lib/Borel/Ceilometer.hs new file mode 100644 --- /dev/null +++ b/lib/Borel/Ceilometer.hs @@ -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) [] diff --git a/lib/Borel/Ceilometer/Instance.hs b/lib/Borel/Ceilometer/Instance.hs new file mode 100644 --- /dev/null +++ b/lib/Borel/Ceilometer/Instance.hs @@ -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 diff --git a/lib/Borel/Chevalier.hs b/lib/Borel/Chevalier.hs new file mode 100644 --- /dev/null +++ b/lib/Borel/Chevalier.hs @@ -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 diff --git a/lib/Borel/Error.hs b/lib/Borel/Error.hs new file mode 100644 --- /dev/null +++ b/lib/Borel/Error.hs @@ -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 diff --git a/lib/Borel/Marquise.hs b/lib/Borel/Marquise.hs new file mode 100644 --- /dev/null +++ b/lib/Borel/Marquise.hs @@ -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) diff --git a/lib/Borel/Types.hs b/lib/Borel/Types.hs new file mode 100644 --- /dev/null +++ b/lib/Borel/Types.hs @@ -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 diff --git a/lib/Borel/Types/Metric.hs b/lib/Borel/Types/Metric.hs new file mode 100644 --- /dev/null +++ b/lib/Borel/Types/Metric.hs @@ -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 + } diff --git a/lib/Borel/Types/Result.hs b/lib/Borel/Types/Result.hs new file mode 100644 --- /dev/null +++ b/lib/Borel/Types/Result.hs @@ -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 diff --git a/lib/Borel/Types/UOM.hs b/lib/Borel/Types/UOM.hs new file mode 100644 --- /dev/null +++ b/lib/Borel/Types/UOM.hs @@ -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 + diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -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