diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,7 @@ # Revision history for grafana-dashboarding -## 0.1.0.0 -- YYYY-mm-dd +## 0.2 +Add Layout and Plugin machinery. +## 0.1 * First version. Released on an unsuspecting world. diff --git a/grafana.cabal b/grafana.cabal --- a/grafana.cabal +++ b/grafana.cabal @@ -1,47 +1,52 @@ cabal-version: 2.2 -name: - grafana -version: - 0.1 -synopsis: - grafana datatypes for dashboards +name: grafana +version: 0.2 +license: BSD-3-Clause +license-file: LICENSE +maintainer: Ethan Jones +author: Ethan Jones +synopsis: API for creating grafana dashboards represented as json description: - 'grafana' provides datatypes that correspond to components of - grafana dashboards, and combinators for constructing dashboards. - It should be suitable for a UI that allows users to construct - grafana dashboards. -license: - BSD-3-Clause -license-file: - LICENSE -author: - Ethan Jones -maintainer: - Ethan Jones -category: - Graphics, Tooling + 'grafana' provides datatypes that correspond to components of + grafana dashboards, and combinators for constructing dashboards. + It should be suitable for a UI that allows users to construct + grafana dashboards. +category: Graphics, Tooling extra-source-files: - CHANGELOG.md + CHANGELOG.md +source-repository head + type: git + location: git://github.com/chessai/grafana.git + library - exposed-modules: - Grafana - build-depends: - , base >= 4.10 && < 4.13 - , bytestring >= 0.10 && < 0.11 - , aeson >= 1.3 && < 1.5 - , aeson-pretty >= 0.8 && < 0.9 - , text >= 1.2 && < 1.3 - hs-source-dirs: - src - default-language: - Haskell2010 - ghc-options: - -Wall - -O2 + exposed-modules: + Grafana + Grafana.Layout + Grafana.Plugin.PieChart + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall + build-depends: + base >=4.10 && <4.13, + bytestring >=0.10 && <0.11, + aeson >=1.3 && <1.5, + aeson-pretty >=0.8 && <0.9, + containers -any, + text >=1.2 && <1.3 -source-repository head - type: - git - location: - git://github.com/chessai/grafana.git +test-suite unit + type: exitcode-stdio-1.0 + main-is: UnitTests.hs + hs-source-dirs: test + default-language: Haskell2010 + ghc-options: -Wall + build-depends: + aeson >=1.3 && <1.5, + aeson-pretty >=0.8 && <0.9, + base ^>=4.12.0.0, + bytestring >=0.10 && <0.11, + Diff -any, + grafana -any, + tasty -any, + tasty-hunit -any diff --git a/src/Grafana.hs b/src/Grafana.hs --- a/src/Grafana.hs +++ b/src/Grafana.hs @@ -9,41 +9,65 @@ , GeneralizedNewtypeDeriving , LambdaCase , OverloadedStrings + , RecordWildCards #-} module Grafana - ( ColumnSort(..) + ( ColorMode(..) + , ColumnSort(..) + , ColumnStyles(..) , Dashboard(..) , GraphiteQuery(..) , Gauge(..) - , Sparkline(..) - , UnitFormat(..) - , Panel - , PanelStyles(..) + , Graph(..) + , GridPos(..) + , Heatmap(..) + , NullPointMode(..) + , Panel(..) + , PanelConfig , PathComponent(..) , RGBA(..) + , Row(..) + , Singlestat(..) , SortOrder(..) + , Sparkline(..) , StyleThresholds(..) + , Table(..) + , TableTransform(..) + , Target(..) , Templating(..) , TimeAmount(..) , TimeRange(..) , TimeUnit(..) + , UnitFormat(..) , columns , defaultDashboard , defaultStyles , defaultGauge + , defaultGraph + , defaultHeatmap + , defaultSinglestat , defaultSparkline + , defaultTable , getDashboardJSON - , graph - , layoutUniformPanels + , makeTargets , maxDashboardWidth , move - , panelAt + , row - , singlestatQuery + , rowPanel + , graph + , graphPanel + , heatmap + , heatmapPanel , table - , htmlPanel + , tablePanel + , text + , textPanel + , serializeQuery + , singlestat + , singlestatPanel ) where import Data.Aeson (ToJSON(..), FromJSON(..)) @@ -63,11 +87,13 @@ import qualified Data.List.NonEmpty as NE import qualified Data.Text as T +type PanelConfig = [(Text, AE.Value)] + tshow :: Show a => a -> Text tshow = T.pack . show {-# inlineable tshow #-} -- not exported, should inline anyway -optionalField :: ToJSON a => Text -> Maybe a -> [(Text,AE.Value)] +optionalField :: ToJSON a => Text -> Maybe a -> PanelConfig optionalField key = \case Nothing -> [] Just x -> [ key .= x ] @@ -109,16 +135,21 @@ firstOption = NE.head (templatingOptions t) optionsRegex :: NonEmpty Text -> Text -optionsRegex options = "/" +optionsRegex options = "/^(" <> T.intercalate "|" (stripInvalidChars <$> NE.toList options) - <> "/" + <> ")$/" data UnitFormat = PercentUnitFormat | PercentFormat | DBmFormat + | DbFormat | SecondsFormat | MillisecondsFormat + | BpsFormat + | ShortFormat + | NoFormat + | OtherFormat Text deriving stock (Eq, Generic, Read, Show) instance ToJSON UnitFormat where @@ -126,30 +157,13 @@ PercentFormat -> "percent" PercentUnitFormat -> "percentunit" DBmFormat -> "dBm" + DbFormat -> "dB" SecondsFormat -> "s" MillisecondsFormat -> "ms" - -data PanelType - = GraphPanel - | SinglestatPanel - | TablePanel - | HeatmapPanel - | AlertListPanel - | DashboardListPanel - | TextPanel - | RowPanel - deriving stock (Eq, Generic, Read, Show) - -instance ToJSON PanelType where - toJSON = \case - GraphPanel -> "graph" - SinglestatPanel -> "singlestat" - TablePanel -> "table" - HeatmapPanel -> "heatmap" - AlertListPanel -> "alertlist" - DashboardListPanel -> "dashboardlist" - TextPanel -> "text" - RowPanel -> "row" + BpsFormat -> "bps" + ShortFormat -> "short" + NoFormat -> "none" + OtherFormat t -> String t data GridPos = GridPos { panelWidth :: !Int @@ -190,11 +204,6 @@ Nothing -> Array mempty Just xs -> toJSON xs -data Panel = Panel - { panelQueryPanel :: !QueryPanel - , panelGridPos :: !GridPos - } deriving stock (Eq, Generic, Read, Show) - data RGBA = RGBA !Word8 !Word8 !Word8 !Double | RGB !Word8 !Word8 !Word8 @@ -275,106 +284,193 @@ , "show" .= True ] -data PanelStyles = PanelStyles +data StyleType + = NumberStyleType + | StringStyleType + | DateStyleType + | HiddenStyleType + deriving (Eq, Show) + +instance ToJSON StyleType where + toJSON = \case + NumberStyleType -> "number" + StringStyleType -> "string" + DateStyleType -> "date" + HiddenStyleType -> "hidden" + +data ColumnStyles = ColumnStyles { alias :: !Text - , colorMode :: !Text + , colorMode :: !ColorMode , colors :: [RGBA] - , columnsSort :: !(Maybe ColumnSort) , decimals :: !Int - , fontsize :: !Int - , styleThresholds :: !(StyleThresholds Double) - , styleUnit :: !(Maybe UnitFormat) - , transparent :: !Bool - , gauge :: !(Maybe Gauge) - , colorBackground :: !Bool - , colorValue :: !Bool - , sparkline :: !(Maybe Sparkline) - } deriving stock (Eq, Generic, Read, Show) + , patternRegex :: !Text + , thresholds :: !(StyleThresholds Double) + , unit :: !UnitFormat + , styleType :: StyleType + , dateFormat :: Maybe Text + } + deriving (Eq, Show) -defaultStyles :: PanelStyles -defaultStyles = PanelStyles +data ColorMode + = ColorDisabled + | ColorCell + | ColorValue + | ColorRow + deriving (Eq, Show) + +instance ToJSON ColorMode where + toJSON = \case + ColorDisabled -> Null + ColorCell -> String "cell" + ColorValue -> String "value" + ColorRow -> String "row" + +defaultStyles :: ColumnStyles +defaultStyles = ColumnStyles { alias = "" - , colorMode = "cell" + , colorMode = ColorDisabled , colors = [] - , columnsSort = Nothing + , dateFormat = Nothing , decimals = 2 - , fontsize = 80 - , styleThresholds = StyleThresholds [] - , styleUnit = Nothing - , transparent = False - , gauge = Nothing - , colorBackground = True - , colorValue = False - , sparkline = Nothing + , patternRegex = "/.*/" + , styleType = NumberStyleType + , thresholds = StyleThresholds [] + , unit = ShortFormat } -instance ToJSON PanelStyles where +data Thresholds = Thresholds Double Double + deriving (Eq, Show) + +instance ToJSON Thresholds where + toJSON (Thresholds l u) = String (tshow l <> "," <> tshow u) + +defaultSinglestat :: Singlestat +defaultSinglestat = Singlestat + { singlestatTitle = "" + , singlestatQueries = [] + , singlestatFontSize = 100 + , singlestatUnit = NoFormat + , singlestatColorBackground = False + , singlestatColorValue = True + , singlestatColors = [] + , singlestatGauge = Nothing + , singlestatSparkline = Nothing + , singlestatThresholds = Nothing + } + +instance ToJSON ColumnStyles where toJSON o = object [ "alias" .= alias o , "colorMode" .= colorMode o , "colors" .= colors o , "decimals" .= decimals o - , "unit" .= String "short" - , "type" .= String "number" - , "pattern" .= String "/.*/" - , "thresholds" .= fmap tshow (styleThresholds o) - , "unit" .= styleUnit o + , "unit" .= unit o + , "type" .= styleType o + , "pattern" .= patternRegex o + , "thresholds" .= fmap tshow (thresholds o) ] -data QueryPanel = QueryPanel - { queryPanelType :: !PanelType - , queryPanelTitle :: !Text - , queryPanelQueries :: [GraphiteQuery] - , queryPanelColumns :: !PanelColumns - , queryPanelStyles :: !PanelStyles - , queryPanelContent :: !Text - } deriving stock (Eq, Generic, Read, Show) - -instance ToJSON QueryPanel where - toJSON = object . queryPanelToPairs - instance ToJSON ColumnSort where toJSON (ColumnSort n sortOrder) = object [ "col" .= n , "desc" .= (sortOrder == Descending) ] -queryPanelToPairs :: QueryPanel -> [(Text,AE.Value)] -queryPanelToPairs p = - [ "type" .= queryPanelType p - , "title" .= queryPanelTitle p - , "targets" .= makeTargets (queryPanelQueries p) - , "columns" .= queryPanelColumns p - , "valueFontSize" .= (String $ tshow (fontsize (queryPanelStyles p)) <> "%") - , "content" .= queryPanelContent p - , "transparent" .= transparent (queryPanelStyles p) - , "mode" .= String "html" - ] <> - case queryPanelType p of - SinglestatPanel -> - [ "format" .= styleUnit (queryPanelStyles p) - , "thresholds" .= - let (StyleThresholds xs) = styleThresholds (queryPanelStyles p) - in T.intercalate "," (tshow <$> xs) - , "colorBackground" .= colorBackground (queryPanelStyles p) - , "colorValue" .= colorValue (queryPanelStyles p) - , "colors" .= colors (queryPanelStyles p) - ] - <> optionalField "gauge" (gauge (queryPanelStyles p)) - <> optionalField "sparkline" (sparkline (queryPanelStyles p)) - TablePanel -> - [ "styles" .= [queryPanelStyles p] - , "transform" .= ("timeseries_aggregations" :: Text) - ] - <> optionalField "sort" (columnsSort (queryPanelStyles p)) - GraphPanel -> - [ "nullPointMode" .= String "connected" - ] - _ -> [] +row :: Row -> PanelConfig +row (Row t) = [ "type" .= String "row", "title" .= t ] +singlestat :: Singlestat -> PanelConfig +singlestat (Singlestat {..}) = + [ "type" .= String "singlestat" + , "title" .= singlestatTitle + , "targets" .= makeTargets singlestatQueries + , "valueFontSize" .= singlestatFontSize + , "format" .= singlestatUnit + , "colorBackground" .= singlestatColorBackground + , "colorValue" .= singlestatColorValue + , "colors" .= singlestatColors + ] + <> optionalField "gauge" singlestatGauge + <> optionalField "sparkline" singlestatSparkline + <> optionalField "thresholds" singlestatThresholds + +table :: Table -> PanelConfig +table (Table {..}) = + [ "type" .= String "table" + , "title" .= tableTitle + , "targets" .= makeTargets tableQueries + , "columns" .= tableColumns + , "valueFontSize" .= tableFontSize + , "styles" .= tableStyles + , "transform" .= tableTransform + ] + <> optionalField "sort" tableSort + +graph :: Graph -> PanelConfig +graph (Graph {..}) = + [ "type" .= String "graph" + , "title" .= graphTitle + , "targets" .= makeTargets graphQueries + , "nullPointMode" .= graphNullPointMode + , "bars" .= graphHasBars + , "steppedLine" .= graphHasSteppedLine + ] + <> case graphUnit of + Nothing -> [] + Just su -> + [ "yaxes" .= + [ object + [ "format" .= su + , "label" .= Null + , "logBase" .= Number 1 + , "max" .= Null + , "min" .= Null + , "show" .= True + ] + , object + [ "format" .= String "short" + , "label" .= Null + , "logBase" .= Number 1 + , "max" .= Null + , "min" .= Null + , "show" .= True + ] + ] + ] + +rowPanel :: Row -> GridPos -> Panel +rowPanel = Panel . row + +graphPanel :: Graph -> GridPos -> Panel +graphPanel = Panel . graph + +tablePanel :: Table -> GridPos -> Panel +tablePanel = Panel . table + +textPanel :: TextPanel -> GridPos -> Panel +textPanel = Panel . text + +singlestatPanel :: Singlestat -> GridPos -> Panel +singlestatPanel = Panel . singlestat + + +text :: TextPanel -> PanelConfig +text (TextPanel {..}) = + [ "type" .= String "text" + , "title" .= textTitle + , "content" .= textContent + , "transparent" .= textIsTransparent + ] + +data Panel = Panel + { panelObject :: PanelConfig + , panelGridPos :: GridPos + } + deriving stock (Eq, Generic, Read, Show) + instance ToJSON Panel where toJSON p = object $ - ( "gridPos" .= panelGridPos p ) : queryPanelToPairs (panelQueryPanel p) + ( "gridPos" .= panelGridPos p ) : panelObject p data TimeUnit = Seconds @@ -486,55 +582,128 @@ (\refid query -> Target refid (serializeQuery query)) refids where - refids = T.singleton <$> (repeat 'A') + refids = fmap (\n -> "I" <> tshow n) [(0 :: Int) ..] -table :: PanelStyles -> Text -> [Column] -> ColumnSort -> [GraphiteQuery] -> QueryPanel -table style label cols colSort queries = QueryPanel - TablePanel - label - queries - (PanelColumns $ Just cols) - (style { columnsSort = Just colSort }) - "" +data Table = Table + { tableTitle :: Text + , tableQueries :: [GraphiteQuery] + , tableColumns :: [Column] + , tableSort :: Maybe ColumnSort + , tableFontSize :: Int + , tableStyles :: [ColumnStyles] + , tableTransform :: TableTransform + } + deriving (Eq, Show) -graph :: Text -> [GraphiteQuery] -> QueryPanel -graph label queries = QueryPanel - GraphPanel - label - queries - (PanelColumns Nothing) - defaultStyles - "" +defaultTable :: Table +defaultTable = Table + { tableTitle = "" + , tableQueries = [] + , tableColumns = [] + , tableSort = Nothing + , tableFontSize = 100 + , tableStyles = [] + , tableTransform = TimeSeriesAggregations + } -row :: Text -> QueryPanel -row label = QueryPanel - RowPanel - label - [] - (PanelColumns Nothing) - defaultStyles - "" +data TableTransform + = TimeSeriesToColumns + | TimeSeriesToRows + | TimeSeriesAggregations + deriving (Eq, Show) +instance ToJSON TableTransform where + toJSON = \case + TimeSeriesToColumns -> "timeseries_to_columns" + TimeSeriesToRows -> "timeseries_to_rows" + TimeSeriesAggregations -> "timeseries_aggregations" + +data NullPointMode = Connected + +instance ToJSON NullPointMode where + toJSON Connected = String "connected" + +data Graph = Graph + { graphTitle :: Text + , graphQueries :: [GraphiteQuery] + , graphNullPointMode :: NullPointMode + , graphUnit :: Maybe UnitFormat + , graphHasBars :: Bool + , graphHasSteppedLine :: Bool + } + +defaultGraph :: Graph +defaultGraph = Graph + { graphTitle = "" + , graphQueries = [] + , graphNullPointMode = Connected + , graphUnit = Nothing + , graphHasBars = False + , graphHasSteppedLine = False + } + +data TextPanel = TextPanel + { textTitle :: Text + , textContent :: Text + , textMode :: TextMode + , textIsTransparent :: Bool + } + +data TextMode = Markdown | Html + +instance ToJSON TextMode where + toJSON = \case + Markdown -> "markdown" + Html -> "html" + +data Singlestat = Singlestat + { singlestatTitle :: Text + , singlestatQueries :: [GraphiteQuery] + , singlestatFontSize :: Int + , singlestatUnit :: UnitFormat + , singlestatColorBackground :: Bool + , singlestatColorValue :: Bool + , singlestatColors :: [RGBA] + , singlestatGauge :: Maybe Gauge + , singlestatSparkline :: Maybe Sparkline + , singlestatThresholds :: Maybe Thresholds + } + deriving (Eq, Show) + +newtype Row = Row Text + data GraphiteQuery = HighestCurrent GraphiteQuery !Int | AverageSeriesWithWildcards GraphiteQuery !Int | AliasSub GraphiteQuery !Text !Text + | Alias GraphiteQuery !Text | Avg GraphiteQuery + | Absolute GraphiteQuery + | Offset GraphiteQuery !Int | Metric [PathComponent Text] | LiteralQuery !Text deriving stock (Eq, Read, Show) serializeQuery :: GraphiteQuery -> Text -serializeQuery (HighestCurrent q n) = - "highestCurrent(" <> serializeQuery q <> "," <> tshow n <> ")" -serializeQuery (AverageSeriesWithWildcards q n) = - "averageSeriesWithWildcards(" <> serializeQuery q <> "," <> tshow n <> ")" -serializeQuery (AliasSub q a b) = - "aliasSub(" <> serializeQuery q <> ",'" <> a <> "','" <> b <> "')" -serializeQuery (Avg q) = "avg(" <> serializeQuery q <> ")" -serializeQuery (Metric xs) = T.intercalate "." - (serializePathComponent . fmap stripInvalidChars <$> xs) -serializeQuery (LiteralQuery t) = t +serializeQuery = \case + HighestCurrent q n -> + "highestCurrent(" <> serializeQuery q <> "," <> tshow n <> ")" + AverageSeriesWithWildcards q n -> + "averageSeriesWithWildcards(" <> serializeQuery q <> "," <> tshow n <> ")" + AliasSub q a b -> + "aliasSub(" <> serializeQuery q <> ",'" <> a <> "','" <> b <> "')" + Alias q a -> + "alias(" <> serializeQuery q <> ",'" <> a <> "')" + Avg q -> + "avg(" <> serializeQuery q <> ")" + Absolute q -> + "absolute(" <> serializeQuery q <> ")" + Offset q n -> + "offset(" <> serializeQuery q <> "," <> tshow n <> ")" + Metric xs -> + T.intercalate "." (serializePathComponent . fmap stripInvalidChars <$> xs) + LiteralQuery t -> + t stripInvalidChars :: Text -> Text stripInvalidChars = T.filter (\c -> isAlphaNum c || c == '-' || c == '_') @@ -557,31 +726,6 @@ getDashboardJSON :: Dashboard -> ByteString getDashboardJSON = BL.toStrict . encodePretty -htmlPanel :: Text -> QueryPanel -htmlPanel content = QueryPanel - TextPanel - "" - [] - (PanelColumns Nothing) - defaultStyles { transparent = True } - content - -singlestatQuery :: PanelStyles -> Text -> [GraphiteQuery] -> QueryPanel -singlestatQuery style label queries = QueryPanel - SinglestatPanel - label - queries - (PanelColumns Nothing) - style - "" - -panelAt :: Int -> Int -> Int -> Int -> QueryPanel -> [Panel] -panelAt left top width height queryPanel = - [ Panel - queryPanel - (GridPos width height left top) - ] - move :: Int -> Int -> Panel -> Panel move dx dy panel = let @@ -590,12 +734,73 @@ in panel { panelGridPos = newPos } -layoutUniformPanels :: Int -> Int -> Int -> Int -> [QueryPanel] -> [Panel] -layoutUniformPanels left top width height queryPanels = - zipWith - Panel - queryPanels - [ GridPos width height x y - | y <- [top, height..] - , x <- [left, width..maxDashboardWidth-1] +data Heatmap = Heatmap + { heatmapColor :: HeatmapColor + , heatmapTitle :: Text + , heatmapTargets :: [GraphiteQuery] + , heatmapDataFormat :: HeatmapDataFormat + } + +defaultHeatmap :: Heatmap +defaultHeatmap = Heatmap + { heatmapColor = defaultHeatmapColor + , heatmapTitle = "" + , heatmapTargets = [] + , heatmapDataFormat = TsBuckets + } + +heatmap :: Heatmap -> PanelConfig +heatmap Heatmap {..} = + [ "type" .= String "heatmap" + , "title" .= heatmapTitle + , "color" .= heatmapColor + , "dataFormat" .= heatmapDataFormat + , "tooltip" .= object [ "show" .= False, "showHistogram" .= False ] ] + +heatmapPanel :: Heatmap -> GridPos -> Panel +heatmapPanel = Panel . heatmap + +data HeatmapColor = HeatmapColor + { heatmapColorScheme :: HeatmapColorScheme + , heatmapMin :: Maybe Double + , heatmapMax :: Maybe Double + } deriving (Generic, Show) + +instance ToJSON HeatmapColor where + toJSON o = object $ + [ "mode" .= String "spectrum" + , "cardColor" .= RGB 0xb4 0xff 0x00 + , "colorScale" .= String "sqrt" + , "exponent" .= Number 0.5 + , "colorScheme" .= heatmapColorScheme o + ] + <> optionalField "min" (heatmapMin o) + <> optionalField "max" (heatmapMax o) + +defaultHeatmapColor :: HeatmapColor +defaultHeatmapColor = HeatmapColor + { heatmapColorScheme = Oranges + , heatmapMax = Nothing + , heatmapMin = Nothing + } + +data HeatmapColorScheme + = Oranges + | RdYlGn + deriving (Generic, Show) + +instance ToJSON HeatmapColorScheme where + toJSON = \case + Oranges -> String "interpolateOranges" + RdYlGn -> String "interpolateRdYlGn" + +data HeatmapDataFormat + = Timeseries + | TsBuckets + deriving (Generic, Show) + +instance ToJSON HeatmapDataFormat where + toJSON = \case + Timeseries -> String "timeseries" + TsBuckets -> String "tsbuckets" diff --git a/src/Grafana/Layout.hs b/src/Grafana/Layout.hs new file mode 100644 --- /dev/null +++ b/src/Grafana/Layout.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} + +module Grafana.Layout where + +import Data.Bifunctor +import Data.Foldable + +data Pos = Pos !Int !Int + deriving (Eq, Show) + +data Rect = Rect + { left :: !Int + , right :: !Int + , top :: !Int + , bottom :: !Int + } deriving (Eq, Show) + +instance Semigroup Rect where + Rect l r t b <> Rect l' r' t' b' = + Rect (min l l') (max r r') (min t t') (max b b') + +data Layout a + = Layout [(Rect, a)] Rect + | Empty + deriving (Eq, Show, Functor) + +instance Semigroup (Layout a) where + Layout ars ab <> Layout brs bb = Layout (ars <> brs) (ab <> bb) + a <> Empty = a + Empty <> a = a + +instance Monoid (Layout a) where + mempty = Empty + +moveLayout :: Pos -> Layout a -> Layout a +moveLayout _ Empty = Empty +moveLayout p (Layout xs rect) = + Layout + (map (first (moveRect p)) xs) + (moveRect p rect) + +moveRect :: Pos -> Rect -> Rect +moveRect (Pos x y) (Rect l r t b) = Rect (l + x) (r + x) (t + y) (b + y) + +atop :: Layout a -> Layout a -> Layout a +atop a b = a <> moveLayout (Pos 0 (bottoml a)) b + +nextTo :: Layout a -> Layout a -> Layout a +nextTo a b = a <> moveLayout (Pos (rightl a) 0) b + +rightl :: Layout a -> Int +rightl Empty = 0 +rightl (Layout _ r) = right r + +bottoml :: Layout a -> Int +bottoml Empty = 0 +bottoml (Layout _ r) = bottom r + +rowFits :: Int -> Int -> Int -> [Rect] +rowFits maxWidth itemCount rowHeight = + fmap (\x -> Rect x (x+width) 0 rowHeight) xs + where + xs = [padding, width + padding..] + width = maxWidth `div` itemCount + padding = maxWidth `mod` itemCount `div` 2 + +fitToRow :: Int -> Int -> [Rect -> Layout a] -> Layout a +fitToRow maxWidth rowHeight items = fold $ + zipWith ($) items (rowFits maxWidth (length items) rowHeight) + +fillRows :: Int -> Int -> Int -> [Rect -> Layout a] -> Layout a +fillRows maxWidth rowHeight cols items + | null thisRow = Empty + | otherwise = + fold (zipWith ($) thisRow (rowFits maxWidth cols rowHeight)) + `atop` fillRows maxWidth rowHeight cols rest + where + (thisRow, rest) = splitAt cols items diff --git a/src/Grafana/Plugin/PieChart.hs b/src/Grafana/Plugin/PieChart.hs new file mode 100644 --- /dev/null +++ b/src/Grafana/Plugin/PieChart.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Grafana.Plugin.PieChart where + +import Data.Aeson (ToJSON(..)) +import Data.Aeson ((.=), Value(..)) +import Data.Map.Strict (Map) +import Data.Text (Text) + +import qualified Data.Aeson as AE + +import Grafana + +data PieType = Donut | Pie + +instance ToJSON PieType where + toJSON = \case + Donut -> "donut" + Pie -> "pie" + +data PieChart = PieChart + { pieChartTitle :: Text + , pieChartQueries :: [GraphiteQuery] + , pieChartUnit :: Maybe UnitFormat + , pieChartAliasColors :: Map Text RGBA + , pieType :: PieType + } + +pieChartToPairs :: PieChart -> [(Text, AE.Value)] +pieChartToPairs (PieChart {..}) = + [ "type" .= String "grafana-piechart-panel" + , "title" .= pieChartTitle + , "targets" .= makeTargets pieChartQueries + , "format" .= pieChartUnit + , "pieType" .= pieType + , "aliasColors" .= pieChartAliasColors + ] + +pieChartPanel :: PieChart -> GridPos -> Panel +pieChartPanel = Panel . pieChartToPairs diff --git a/test/UnitTests.hs b/test/UnitTests.hs new file mode 100644 --- /dev/null +++ b/test/UnitTests.hs @@ -0,0 +1,231 @@ +{-# language + LambdaCase + , OverloadedStrings +#-} + +module Main (main) where + +import Data.Aeson ((.=), Value(..), object, toJSON) +import Data.Aeson.Encode.Pretty (encodePretty) +import Data.Algorithm.Diff (getGroupedDiff) +import Data.Algorithm.DiffOutput (ppDiff) +import Data.Foldable (toList) +import Data.List (group, sort) +import Test.Tasty +import Test.Tasty.HUnit + +import qualified Data.ByteString.Lazy.Char8 as BC8 + +import Grafana +import Grafana.Plugin.PieChart + +main :: IO () +main = defaultMain (testGroup "Tests" [unitTests]) + +unitTests :: TestTree +unitTests = testGroup "Unit tests" + [ testCase "makeTargets makes distinct refIds" makeTargetsDistinctRefids + , graphiteQuerySerialize + , panelSerialize + ] + +makeTargetsDistinctRefids :: Assertion +makeTargetsDistinctRefids = + let query1 = Metric [Literal "a", Literal "b", Literal "c"] + query2 = Metric [Literal "d", Literal "e", Literal "f"] + targets = makeTargets [query1, query2] + in distinctOn refId targets @? "Non-distinct refids" + +distinctOn :: (Eq b, Ord b, Foldable t) => (a -> b) -> t a -> Bool +distinctOn predicate collection = + all isSingleton . group . sort . map predicate . toList $ collection + where + isSingleton = \case + [_] -> True + _ -> False + +graphiteQuerySerialize :: TestTree +graphiteQuerySerialize = testGroup "graphite queries are serialized properly" + [ testCase "alias" serializeAlias + , testCase "aliasSub" serializeAliasSub + , testCase "escaping chars" serializeEscapesBadChars + ] + +serializeAlias :: Assertion +serializeAlias = + let query = Alias (Metric [Anything, Anything, Anything]) "Something else" + in serializeQuery query @?= "alias(*.*.*,'Something else')" + +serializeAliasSub :: Assertion +serializeAliasSub = + let query = AliasSub (Metric [Anything, Anything, Anything]) "X" "Y" + in serializeQuery query @?= "aliasSub(*.*.*,'X','Y')" + +serializeEscapesBadChars :: Assertion +serializeEscapesBadChars = + let query = Metric [Literal "minipops 67 [120.2][source field mix]"] + in serializeQuery query @?= "minipops671202sourcefieldmix" + +panelSerialize :: TestTree +panelSerialize = testGroup "Panel serialization" + [ testCase "row serialization" rowSerialize + , testCase "graph serialization" graphSerialize + , testCase "table serialization" tableSerialize + , testCase "pie chart serialization" pieChartSerialize + , testCase "dashboard serialization" dashboardSerialize + ] + +defGridPos :: GridPos +defGridPos = GridPos 1 1 0 0 + +defGridPosJSON :: Value +defGridPosJSON = + object + [ "h" .= Number 1 + , "w" .= Number 1 + , "x" .= Number 0 + , "y" .= Number 0 + ] + +defQueries :: [GraphiteQuery] +defQueries = + [ Metric [Anything, Anything, Anything] + , Metric [Anything, Anything, Anything] + ] + +defQueriesJSON :: [Value] +defQueriesJSON = + [ object ["refId" .= String "I0", "target" .= String "*.*.*"] + , object ["refId" .= String "I1", "target" .= String "*.*.*"] + ] + +assertEqJSON :: Value -> Value -> Assertion +assertEqJSON a b = + let prettyJSON = lines . BC8.unpack . encodePretty + diff = ppDiff (getGroupedDiff (prettyJSON a) (prettyJSON b)) + in (a == b) @? diff + +rowSerialize :: Assertion +rowSerialize = + assertEqJSON + (toJSON (rowPanel (Row "name") defGridPos)) + (object + [ "gridPos" .= defGridPosJSON + , "title" .= String "name" + , "type" .= String "row" + ]) + +graphSerialize :: Assertion +graphSerialize = + assertEqJSON + (toJSON (graphPanel + (defaultGraph { graphTitle = "name", graphQueries = defQueries }) + defGridPos)) + (object + [ "gridPos" .= defGridPosJSON + , "title" .= String "name" + , "type" .= String "graph" + , "nullPointMode" .= Connected + , "targets" .= defQueriesJSON + , "bars" .= False + , "steppedLine" .= False + ]) + +tableSerialize :: Assertion +tableSerialize = + let + testTable = defaultTable + { tableTitle = "name" + , tableQueries = defQueries + , tableColumns = columns ["Avg", "Current"] + , tableStyles = + [ defaultStyles + { thresholds = StyleThresholds [5, 10] + , decimals = 2 + , unit = PercentFormat + , colorMode = ColorCell + } + ] + } + in + assertEqJSON + (toJSON (tablePanel testTable defGridPos)) + (object + [ "gridPos" .= defGridPosJSON + , "title" .= String "name" + , "type" .= String "table" + , "styles" .= + [ object + [ "pattern" .= String "/.*/" + , "alias" .= String "" + , "thresholds" .= [String "5.0", String "10.0"] + , "decimals" .= Number 2 + , "type" .= String "number" + , "colorMode" .= String "cell" + , "colors" .= Array mempty + , "unit" .= String "percent" + ] + ] + , "targets" .= defQueriesJSON + , "columns" .= + [ object ["text" .= String "Avg", "value" .= String "avg"] + , object ["text" .= String "Current", "value" .= String "current"] + ] + , "valueFontSize" .= Number 100 + , "transform" .= String "timeseries_aggregations" + ]) + +pieChartSerialize :: Assertion +pieChartSerialize = + let + pieChart = PieChart + { pieChartTitle = "name" + , pieChartQueries = defQueries + , pieChartUnit = Just ShortFormat + , pieChartAliasColors = mempty + , pieType = Donut + } + in + assertEqJSON + (toJSON (pieChartPanel pieChart defGridPos)) + (object + [ "gridPos" .= defGridPosJSON + , "title" .= String "name" + , "type" .= String "grafana-piechart-panel" + , "pieType" .= String "donut" + , "aliasColors" .= Object mempty + , "targets" .= defQueriesJSON + , "format" .= String "short" + ]) + +dashboardSerialize :: Assertion +dashboardSerialize = + let + pieChart = PieChart + { pieChartTitle = "name" + , pieChartQueries = defQueries + , pieChartUnit = Just ShortFormat + , pieChartAliasColors = mempty + , pieType = Donut + } + testRow = Row "row name" + panels = + [pieChartPanel pieChart defGridPos, rowPanel testRow defGridPos] + dashboard = defaultDashboard + { dashboardPanels = panels + , dashboardTime = TimeRange (Interval 6 Hours) Nothing + } + in + assertEqJSON + (toJSON dashboard) + (object + [ "panels" .= panels + , "links" .= Array mempty + , "tags" .= Array mempty + , "title" .= String "New dashboard" + , "time" .= object + [ "to" .= String "now" + , "from" .= String "now-6h" + ] + , "templating" .= object [ "list" .= Array mempty ] + ])