{-# language
BangPatterns
, BlockArguments
, DeriveFoldable
, DeriveFunctor
, DeriveGeneric
, DeriveTraversable
, DerivingStrategies
, GeneralizedNewtypeDeriving
, LambdaCase
, OverloadedStrings
, RecordWildCards
#-}
module Grafana
( ColorMode(..)
, ColumnSort(..)
, ColumnStyles(..)
, Dashboard(..)
, GraphiteQuery(..)
, Gauge(..)
, 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
, makeTargets
, maxDashboardWidth
, move
, row
, rowPanel
, graph
, graphPanel
, heatmap
, heatmapPanel
, table
, tablePanel
, text
, textPanel
, serializeQuery
, singlestat
, singlestatPanel
) where
import Data.Aeson (ToJSON(..), FromJSON(..))
import Data.Aeson (Value(..), (.=), object)
import Data.Aeson.Encode.Pretty (encodePretty)
import Data.ByteString (ByteString)
import Data.Char (isAlphaNum)
import Data.Coerce (coerce)
import Data.List.NonEmpty (NonEmpty)
import Data.Maybe (isJust, maybeToList)
import Data.Text (Text)
import Data.Word (Word8)
import GHC.Generics (Generic)
import qualified Data.Aeson as AE
import qualified Data.ByteString.Lazy as BL
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 #-}
optionalField :: ToJSON a => Text -> Maybe a -> PanelConfig
optionalField key = \case
Nothing -> []
Just x -> [ key .= x ]
data Templating = Templating
{ templatingOptions :: NonEmpty Text
, templatingName :: !Text
, templatingLabel :: !Text
, templatingQuery :: !GraphiteQuery
, templatingAllValue :: !(Maybe Text)
} deriving stock (Eq, Read, Show)
instance ToJSON Templating where
toJSON t = object $
[ "datasource" .= String "Graphite"
, "includeAll" .= isJust (templatingAllValue t)
, "type" .= String "query"
, "regex" .= optionsRegex (templatingOptions t)
, "name" .= templatingName t
, "label" .= Null
, "current" .= object
[ "text" .= firstOption
, "value" .= firstOption
]
, "definition" .= query
, "query" .= query
, "options" .= Array mempty
, "tagsQuery" .= String ""
, "tags" .= Array mempty
, "useTags" .= False
, "hide" .= (0 :: Int)
, "multi" .= False
, "refresh" .= (2 :: Int)
, "tagValuesQuery" .= String ""
]
<> optionalField "allValue" (templatingAllValue t)
where
query = serializeQuery (templatingQuery t)
firstOption = NE.head (templatingOptions t)
optionsRegex :: NonEmpty Text -> Text
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
toJSON = \case
PercentFormat -> "percent"
PercentUnitFormat -> "percentunit"
DBmFormat -> "dBm"
DbFormat -> "dB"
SecondsFormat -> "s"
MillisecondsFormat -> "ms"
BpsFormat -> "bps"
ShortFormat -> "short"
NoFormat -> "none"
OtherFormat t -> String t
data GridPos = GridPos
{ panelWidth :: !Int
, panelHeight :: !Int
, panelXPosition :: !Int
, panelYPosition :: !Int
} deriving stock (Eq, Generic, Read, Show)
instance ToJSON GridPos where
toJSON (GridPos w h x y) =
object
[ "w" .= w
, "h" .= h
, "x" .= x
, "y" .= y
]
data Column = Column
{ columnLabel :: !Text
, columnValue :: !Text
} deriving stock (Eq, Generic, Read, Show)
instance ToJSON Column where
toJSON (Column label value) =
object
[ "text" .= String label
, "value" .= String value
]
columns :: [Text] -> [Column]
columns = fmap (\name -> Column (T.toTitle name) (T.toLower name))
newtype PanelColumns = PanelColumns (Maybe [Column])
deriving stock (Eq, Generic, Read, Show)
instance ToJSON PanelColumns where
toJSON (PanelColumns x) = case x of
Nothing -> Array mempty
Just xs -> toJSON xs
data RGBA
= RGBA !Word8 !Word8 !Word8 !Double
| RGB !Word8 !Word8 !Word8
deriving stock (Eq, Generic, Read, Show)
instance ToJSON RGBA where
toJSON (RGBA r g b a) = String $
"rgba(" <>
tshow r <> ", " <>
tshow g <> ", " <>
tshow b <> ", " <>
tshow a <> ")"
toJSON (RGB r g b) = String $
"rgb(" <>
tshow r <> ", " <>
tshow g <> ", " <>
tshow b <> ")"
newtype StyleThresholds a = StyleThresholds [a]
deriving stock (Generic, Read, Show)
deriving newtype (Eq, ToJSON, FromJSON)
deriving newtype (Functor, Foldable)
instance Traversable StyleThresholds where
traverse f = fmap StyleThresholds . traverse f . coerce
{-# inline traverse #-}
data SortOrder
= Ascending
| Descending
deriving stock (Eq, Generic, Read, Show)
data ColumnSort = ColumnSort !Int !SortOrder
deriving stock (Eq, Generic, Read, Show)
data Gauge = Gauge
{ minValue :: !Int
, maxValue :: !Int
, thresholdMarkers :: !Bool
, thresholdLabels :: !Bool
} deriving stock (Eq, Generic, Read, Show)
defaultGauge :: Gauge
defaultGauge = Gauge
{ minValue = 0
, maxValue = 100
, thresholdMarkers = True
, thresholdLabels = False
}
instance ToJSON Gauge where
toJSON g = object
[ "minValue" .= minValue g
, "maxValue" .= maxValue g
, "thresholdMarkers" .= thresholdMarkers g
, "thresholdLabels" .= thresholdLabels g
, "show" .= True
]
data Sparkline = Sparkline
{ fillColor :: !RGBA
, full :: !Bool
, lineColor :: !RGBA
} deriving stock (Eq, Generic, Read, Show)
defaultSparkline :: Sparkline
defaultSparkline = Sparkline
{ fillColor = RGBA 31 118 189 0.18
, full = False
, lineColor = RGB 31 120 193
}
instance ToJSON Sparkline where
toJSON s = object
[ "fillColor" .= fillColor s
, "full" .= full s
, "lineColor" .= lineColor s
, "show" .= True
]
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 :: !ColorMode
, colors :: [RGBA]
, decimals :: !Int
, patternRegex :: !Text
, thresholds :: !(StyleThresholds Double)
, unit :: !UnitFormat
, styleType :: StyleType
, dateFormat :: Maybe Text
}
deriving (Eq, Show)
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 = ColorDisabled
, colors = []
, dateFormat = Nothing
, decimals = 2
, patternRegex = "/.*/"
, styleType = NumberStyleType
, thresholds = StyleThresholds []
, unit = ShortFormat
}
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" .= unit o
, "type" .= styleType o
, "pattern" .= patternRegex o
, "thresholds" .= fmap tshow (thresholds o)
]
instance ToJSON ColumnSort where
toJSON (ColumnSort n sortOrder) = object
[ "col" .= n
, "desc" .= (sortOrder == Descending)
]
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 ) : panelObject p
data TimeUnit
= Seconds
| Minutes
| Hours
| Days
deriving stock (Eq, Generic, Read, Show)
data TimeAmount = Interval !Int !TimeUnit
deriving stock (Eq, Generic, Read, Show)
displayTimeAmount :: TimeAmount -> Text
displayTimeAmount (Interval n units) =
case units of
Seconds -> (tshow n <> "s")
Minutes -> (tshow n <> "m")
Hours -> (tshow n <> "h")
Days -> (tshow n <> "d")
instance ToJSON TimeAmount where
toJSON = String . displayTimeAmount
data TimeRange = TimeRange
{ rangeFrom :: !TimeAmount
, rangeTo :: !(Maybe TimeAmount)
} deriving stock (Eq, Generic, Read, Show)
instance ToJSON TimeRange where
toJSON range =
object
[ "from" .= ("now-" <> displayTimeAmount (rangeFrom range))
, "to" .=
case rangeTo range of
Nothing -> "now"
Just r -> "now-" <> displayTimeAmount r
]
maxDashboardWidth :: Int
maxDashboardWidth = 24
data Dashboard = Dashboard
{ dashboardIdentifier :: !(Maybe Int)
, dashboardUid :: !(Maybe Text)
, dashboardTitle :: !Text
, dashboardTime :: !TimeRange
, dashboardRefresh :: !TimeAmount
, dashboardVersion :: !Int
, dashboardPanels :: [Panel]
, dashboardTemplating :: [Templating]
, dashboardLinks :: [Link]
, dashboardTags :: [Text]
} deriving stock (Eq, Generic, Read, Show)
instance ToJSON Dashboard where
toJSON g = object $
[ "panels" .= dashboardPanels g
, "title" .= dashboardTitle g
, "time" .= dashboardTime g
, "templating" .= object
[ "list" .= dashboardTemplating g
]
, "links" .= dashboardLinks g
, "tags" .= dashboardTags g
] <> maybeToList (("uid" .=) <$> dashboardUid g)
defaultDashboard :: Dashboard
defaultDashboard = Dashboard
{ dashboardIdentifier = Nothing
, dashboardUid = Nothing
, dashboardTitle = "New dashboard"
, dashboardPanels = []
, dashboardTime = TimeRange (Interval 1 Hours) Nothing
, dashboardRefresh = Interval 5 Seconds
, dashboardVersion = 1
, dashboardTemplating = []
, dashboardLinks = []
, dashboardTags = []
}
data Target = Target
{ refId :: !Text
, targetVal :: !Text
} deriving (Eq, Generic, Read, Show)
instance ToJSON Target where
toJSON g =
object
[ "refId" .= refId g
, "target" .= targetVal g
]
data Link = Link
{ tags :: [Text]
, title :: !Text
} deriving (Eq, Generic, Read, Show)
instance ToJSON Link where
toJSON g =
object
[ "asDropdown" .= True
, "icon" .= String "external link"
, "tags" .= tags g
, "title" .= title g
, "type" .= String "dashboards"
]
makeTargets :: [GraphiteQuery] -> [Target]
makeTargets = zipWith
(\refid query -> Target refid (serializeQuery query))
refids
where
refids = fmap (\n -> "I" <> tshow n) [(0 :: Int) ..]
data Table = Table
{ tableTitle :: Text
, tableQueries :: [GraphiteQuery]
, tableColumns :: [Column]
, tableSort :: Maybe ColumnSort
, tableFontSize :: Int
, tableStyles :: [ColumnStyles]
, tableTransform :: TableTransform
}
deriving (Eq, Show)
defaultTable :: Table
defaultTable = Table
{ tableTitle = ""
, tableQueries = []
, tableColumns = []
, tableSort = Nothing
, tableFontSize = 100
, tableStyles = []
, tableTransform = TimeSeriesAggregations
}
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 = \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 == '_')
data PathComponent a
= Anything
| Variable !Text
| Literal a
| OneOf [a]
deriving stock (Eq, Ord, Read, Show)
deriving stock (Functor, Foldable, Traversable)
serializePathComponent :: PathComponent Text -> Text
serializePathComponent = \case
Anything -> "*"
Variable v -> "$" <> v
Literal name -> name
OneOf xs -> "{" <> T.intercalate "," xs <> "}"
getDashboardJSON :: Dashboard -> ByteString
getDashboardJSON = BL.toStrict . encodePretty
move :: Int -> Int -> Panel -> Panel
move dx dy panel =
let
GridPos w h x y = panelGridPos panel
newPos = GridPos w h (x + dx) (y + dy)
in
panel { panelGridPos = newPos }
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"