diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,17 @@ +# Change log + +## 0.1.0.0 + Mark Hopkins Jun 2017 + + - Basics of the alerta API, including + - alerts + - alert queries, history, top 10 and flapping + - environments + - services + - blackouts + - heartbeats + - API keys + - users + - customers + + Not yet covered: OAuth integration. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Mark Hopkins (c) 2017 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Mark Hopkins nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,3 @@ +# alerta-client + +Haskell bindings for the [Alerta](http://alerta.io) REST API. 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/alerta.cabal b/alerta.cabal new file mode 100644 --- /dev/null +++ b/alerta.cabal @@ -0,0 +1,50 @@ +name: alerta +version: 0.1.0.0 +synopsis: Bindings to the alerta REST API +homepage: https://github.com/mjhopkins/alerta-client +bug-reports: https://github.com/mjhopkins/alerta-client/issues +license: BSD3 +license-file: LICENSE +author: Mark Hopkins +maintainer: markjohnhopkins@gmail.com +copyright: Mark Hopkins +category: Monitoring, API, Web +build-type: Simple +stability: experimental +extra-source-files: README.md CHANGELOG.md +cabal-version: >= 1.10 +description: + is an alert monitoring tool developed by the + newspaper + . + This package supplies bindings to the alerta REST API so that it can be used + from Haskell. + . + Built with . + +library + hs-source-dirs: src + exposed-modules: Alerta + other-modules: Alerta.Auth + , Alerta.Helpers + , Alerta.ServantExtras + , Alerta.Types + , Alerta.Util + build-depends: base >= 4.7 && < 5 + , aeson + , aeson-pretty + , containers + , data-default + , http-api-data + , http-client + , servant + , servant-client + , servant-server + , text + , time + ghc-options: -Wall + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/mjhopkins/alerta-client diff --git a/src/Alerta.hs b/src/Alerta.hs new file mode 100644 --- /dev/null +++ b/src/Alerta.hs @@ -0,0 +1,294 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} + +-------------------------------------------------------------------------------- +-- | +-- Module: Alerta +-- Description: Bindings to the alerta API +-- +-- The alerta API allows you to query and modify +-- +-- * Alerts +-- +-- * Environments +-- +-- * Services +-- +-- * Blackouts +-- +-- * Heartbeats +-- +-- * API Keys +-- +-- * Users +-- +-- * Customers +-------------------------------------------------------------------------------- + +module Alerta + ( + -- * Bindings + -- ** Alerts + createAlert + , getAlert + , deleteAlert + , setAlertStatus + , tagAlert + , untagAlert + , updateAlertAttributes + -- ** Alert history and alert queries + , listAlerts + , alertHistory + , countAlerts + , top10 + , flappingTop10 + -- ** Environments + , listEnvironments + -- ** Services + , listServices + -- ** Blackouts + , createBlackout + , deleteBlackout + , listBlackouts + -- ** Heartbeats + , createHeartbeat + , getHeartbeat + , deleteHeartbeat + , listHeartbeats + -- ** API keys + , createApiKey + , deleteApiKey + , listApiKeys + -- ** Users + , createUser + , deleteUser + , updateUser + , listUsers + -- ** Customers + , createCustomer + , deleteCustomer + , listCustomers + -- * Types + , module Alerta.Types + -- * Helpers + , module Alerta.Helpers + ) where + +import Alerta.Auth +import Alerta.Helpers +import Alerta.ServantExtras +import Alerta.Types +import Servant +import Servant.Client + +-------------------------------------------------------------------------------- +-- query parameter types +-------------------------------------------------------------------------------- + +type Limited a = QueryParam "limit" Limit :> a + +type Page a = QueryParam "page" PageNo :> a + +type Sort a = + QueryParam "reverse" ShouldReverse + :> QueryParams "sort-by" AlertAttr + :> a + +type Grouped a = + QueryParam "group-by" AlertAttr + :> a + +type Fields a = + QueryParam "fields" [AlertAttr] -- NB not QueryParams "field" AlertAttr + :> QueryParam "fields!" [AlertAttr] -- NB not QueryParams "field!" AlertAttr + :> a + +type Query a = + QueryParam "q" QueryString -- TODO JSON + :> QueryParams "id" UUID + :> QueryFlag "repeat" + :> FieldQueries + :> a + +-------------------------------------------------------------------------------- +-- API types +-------------------------------------------------------------------------------- + +type AlertApi = + WithApiKey :> "alert" :> ReqBody '[JSON] Alert :> Post '[JSON] CreateAlertResp + :<|> WithApiKey :> "alert" :> Capture "id" UUID :> Get '[JSON] AlertResp + :<|> WithApiKey :> "alert" :> Capture "id" UUID :> Delete '[JSON] Resp + :<|> WithApiKey :> "alert" :> Capture "id" UUID :> "status" :> ReqBody '[JSON] StatusChange :> Put '[JSON] Resp + :<|> WithApiKey :> "alert" :> Capture "id" UUID :> "tag" :> ReqBody '[JSON] Tags :> Put '[JSON] Resp + :<|> WithApiKey :> "alert" :> Capture "id" UUID :> "untag" :> ReqBody '[JSON] Tags :> Put '[JSON] Resp + :<|> WithApiKey :> "alert" :> Capture "id" UUID :> "attributes" :> ReqBody '[JSON] Attributes :> Put '[JSON] Resp + +type AlertsApi = + WithApiKey :> "alerts" :> Query (Fields (Sort (Page (Limited (Get '[JSON] AlertsResp))))) + :<|> WithApiKey :> "alerts" :> "history" :> Query (Limited (Get '[JSON] AlertHistoryResp)) + :<|> WithApiKey :> "alerts" :> "count" :> Query (Get '[JSON] AlertCountResp) + :<|> WithApiKey :> "alerts" :> "top10" :> Query (Grouped (Get '[JSON] Top10Resp)) + :<|> WithApiKey :> "alerts" :> "top10" :> "count" :> Query (Grouped (Get '[JSON] Top10Resp)) + :<|> WithApiKey :> "alerts" :> "top10" :> "flapping" :> Query (Grouped (Get '[JSON] Top10Resp)) + +-- An environment cannot be created – it is a dynamically derived resource based on existing alerts. +type EnvironmentApi = + WithApiKey :> "environments" :> Query (Limited (Get '[JSON] EnvironmentsResp)) + +-- A service cannot be created – it is a dynamically derived resource based on existing alerts. +type ServiceApi = + WithApiKey :> "services" :> Query (Limited (Get '[JSON] ServicesResp)) + +type BlackoutApi = + WithApiKey :> "blackout" :> ReqBody '[JSON] Blackout :> Post '[JSON] BlackoutResp + :<|> WithApiKey :> "blackout" :> Capture "blackout" UUID :> Delete '[JSON] Resp + :<|> WithApiKey :> "blackouts" :> Get '[JSON] BlackoutsResp + +type HeartbeatApi = + WithApiKey :> "heartbeat" :> ReqBody '[JSON] Heartbeat :> Post '[JSON] CreateHeartbeatResp + :<|> WithApiKey :> "heartbeat" :> Capture "id" UUID :> Get '[JSON] HeartbeatResp + :<|> WithApiKey :> "heartbeat" :> Capture "id" UUID :> Delete '[JSON] Resp + :<|> WithApiKey :> "heartbeats" :> Get '[JSON] HeartbeatsResp + +type ApiKeyApi = + NeedApiKey :> "key" :> ReqBody '[JSON] CreateApiKey :> Post '[JSON] CreateApiKeyResp + :<|> WithApiKey :> "key" :> Capture "key" ApiKey :> Delete '[JSON] Resp + :<|> WithApiKey :> "keys" :> Get '[JSON] ApiKeysResp + +type UserApi = + WithApiKey :> "user" :> ReqBody '[JSON] User :> Post '[JSON] UserResp + :<|> WithApiKey :> "user" :> Capture "user" UUID :> Delete '[JSON] Resp + :<|> WithApiKey :> "user" :> Capture "user" UUID :> ReqBody '[JSON] (UserAttr 'Nonempty) :> Put '[JSON] Resp + :<|> WithApiKey :> "users" :> QueryParam "name" CustomerName :> QueryParam "login" Email :> Get '[JSON] UsersResp + +type CustomerApi = + WithApiKey :> "customer" :> ReqBody '[JSON] Customer :> Post '[JSON] CustomerResp + :<|> WithApiKey :> "customer" :> Capture "customer" UUID :> Delete '[JSON] Resp + :<|> WithApiKey :> "customers" :> Get '[JSON] CustomersResp + + +-------------------------------------------------------------------------------- +-- client methods +-------------------------------------------------------------------------------- + +createAlert :: Maybe ApiKey -> Alert -> ClientM CreateAlertResp +getAlert :: Maybe ApiKey -> UUID -> ClientM AlertResp +deleteAlert :: Maybe ApiKey -> UUID -> ClientM Resp +setAlertStatus :: Maybe ApiKey -> UUID -> StatusChange -> ClientM Resp +tagAlert :: Maybe ApiKey -> UUID -> Tags -> ClientM Resp +untagAlert :: Maybe ApiKey -> UUID -> Tags -> ClientM Resp +updateAlertAttributes :: Maybe ApiKey -> UUID -> Attributes -> ClientM Resp + +createAlert :<|> + getAlert :<|> + deleteAlert :<|> + setAlertStatus :<|> + tagAlert :<|> + untagAlert :<|> + updateAlertAttributes = client (Proxy :: Proxy AlertApi) + +listAlerts :: + Maybe ApiKey + -> Maybe QueryString + -- ^ this is a JSON document describing a Mongo query + -- see http://docs.mongodb.org/manual/reference/operator/query/ + -> [UUID] + -> IsRepeat + -> [FieldQuery] + -> Maybe [AlertAttr] -- ^ alert attributes to show + -> Maybe [AlertAttr] -- ^ alert attributes to hide + -> Maybe ShouldReverse + -> [AlertAttr] + -> Maybe PageNo + -> Maybe Limit + -> ClientM AlertsResp +alertHistory :: + Maybe ApiKey + -> Maybe QueryString + -> [UUID] + -> IsRepeat + -> [FieldQuery] + -> Maybe Limit + -> ClientM AlertHistoryResp +countAlerts :: + Maybe ApiKey + -> Maybe QueryString + -> [UUID] + -> IsRepeat + -> [FieldQuery] + -> ClientM AlertCountResp +top10 :: + Maybe ApiKey + -> Maybe QueryString + -> [UUID] + -> IsRepeat + -> [FieldQuery] + -> Maybe AlertAttr + -> ClientM Top10Resp +flappingTop10 :: + Maybe ApiKey + -> Maybe QueryString + -> [UUID] + -> IsRepeat + -> [FieldQuery] + -> Maybe AlertAttr + -> ClientM Top10Resp + +listAlerts :<|> + alertHistory :<|> + countAlerts :<|> + top10 :<|> + _ :<|> + flappingTop10 = client (Proxy :: Proxy AlertsApi) + +listEnvironments :: + Maybe ApiKey + -> Maybe QueryString + -> [UUID] + -> IsRepeat + -> [FieldQuery] + -> Maybe Limit + -> ClientM EnvironmentsResp +listEnvironments = client (Proxy :: Proxy EnvironmentApi) + +listServices :: + Maybe ApiKey + -> Maybe QueryString + -> [UUID] + -> IsRepeat + -> [FieldQuery] + -> Maybe Limit + -> ClientM ServicesResp +listServices = client (Proxy :: Proxy ServiceApi) + +createBlackout :: Maybe ApiKey -> Blackout -> ClientM BlackoutResp +deleteBlackout :: Maybe ApiKey -> UUID -> ClientM Resp +listBlackouts :: Maybe ApiKey -> ClientM BlackoutsResp + +createBlackout :<|> deleteBlackout :<|> listBlackouts = client (Proxy :: Proxy BlackoutApi) + +createHeartbeat :: Maybe ApiKey -> Heartbeat -> ClientM CreateHeartbeatResp +getHeartbeat :: Maybe ApiKey -> UUID -> ClientM HeartbeatResp +deleteHeartbeat :: Maybe ApiKey -> UUID -> ClientM Resp +listHeartbeats :: Maybe ApiKey -> ClientM HeartbeatsResp + +createHeartbeat :<|> getHeartbeat :<|> deleteHeartbeat :<|> listHeartbeats = client (Proxy :: Proxy HeartbeatApi) + +createApiKey :: ApiKey -> CreateApiKey -> ClientM CreateApiKeyResp +deleteApiKey :: Maybe ApiKey -> ApiKey -> ClientM Resp +listApiKeys :: Maybe ApiKey -> ClientM ApiKeysResp + +createApiKey :<|> deleteApiKey :<|> listApiKeys = client (Proxy :: Proxy ApiKeyApi) + +createUser :: Maybe ApiKey -> User -> ClientM UserResp +deleteUser :: Maybe ApiKey -> UUID -> ClientM Resp +updateUser :: Maybe ApiKey -> UUID -> UserAttr 'Nonempty -> ClientM Resp +listUsers :: Maybe ApiKey -> Maybe CustomerName -> Maybe Email -> ClientM UsersResp + +createUser :<|> deleteUser :<|> updateUser :<|> listUsers = client (Proxy :: Proxy UserApi) + +createCustomer :: Maybe ApiKey -> Customer -> ClientM CustomerResp +deleteCustomer :: Maybe ApiKey -> UUID -> ClientM Resp +listCustomers :: Maybe ApiKey -> ClientM CustomersResp + +createCustomer :<|> deleteCustomer :<|> listCustomers = client (Proxy :: Proxy CustomerApi) diff --git a/src/Alerta/Auth.hs b/src/Alerta/Auth.hs new file mode 100644 --- /dev/null +++ b/src/Alerta/Auth.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +-------------------------------------------------------------------------------- +-- | +-- Module: Alerta.Auth +-- +-- Auth-related additions to Servant that we use. +-------------------------------------------------------------------------------- +module Alerta.Auth + ( WithApiKey + , NeedApiKey + ) where + +import Alerta.Types (ApiKey(..)) + +import Data.Typeable (Typeable) +import Data.Monoid ((<>)) +import Data.Proxy +import Servant.Common.Req (Req, addHeader) +import Servant.Client +import Servant.API ((:>)) + +data NeedApiKey deriving Typeable +data WithApiKey deriving Typeable + +-- | Authenticate a request using an API key +addApiKey :: ApiKey -> Req -> Req +addApiKey (ApiKey key) = addHeader "Authorization" ("Key " <> key) + +type instance AuthClientData NeedApiKey = ApiKey + +instance HasClient api => HasClient (NeedApiKey :> api) where + type Client (NeedApiKey :> api) = ApiKey -> Client api + + clientWithRoute _ req k = + clientWithRoute (Proxy :: Proxy api) (addApiKey k req) + +type instance AuthClientData WithApiKey = Maybe ApiKey + +instance HasClient api => HasClient (WithApiKey :> api) where + type Client (WithApiKey :> api) = Maybe ApiKey -> Client api + + clientWithRoute _ req m = + clientWithRoute (Proxy :: Proxy api) (maybe id addApiKey m req) diff --git a/src/Alerta/Helpers.hs b/src/Alerta/Helpers.hs new file mode 100644 --- /dev/null +++ b/src/Alerta/Helpers.hs @@ -0,0 +1,70 @@ +-------------------------------------------------------------------------------- +-- | +-- Module: Alerta.Helpers +-- +-- Utilities for manual testing interaction with the API. +-------------------------------------------------------------------------------- +module Alerta.Helpers + ( run + , run' + , prettyPrintEncoding + , now + ) where + +import Control.Monad (void) + +import Data.Aeson +import Data.Aeson.Encode.Pretty +import Data.Bifunctor (bimap) +import qualified Data.Text as T +import Data.Text (Text) +import Data.Time (getCurrentTime, UTCTime) + +import Network.HTTP.Client (Manager, defaultManagerSettings, newManager) + +import Servant.Client +import System.IO.Unsafe + +clientEnv :: Manager -> ClientEnv +clientEnv m = ClientEnv m (BaseUrl Http "localhost" 8080 "") + +-- | Run a Servant client function, pretty-printing the JSON returned. +run :: (Show a, FromJSON a, ToJSON a) => ClientM a -> IO a +run cl = do + manager <- newManager defaultManagerSettings + res <- runClientM cl (clientEnv manager) + either handleError (\r -> prettyPrint r >> putStrLn "Success" >> return r) res + +-- | Run a Servant client function, pretty-printing the JSON returned, and +-- discarding the return value. +run' :: (Show a, FromJSON a, ToJSON a) => ClientM a -> IO () +run' = void . run + +handleError :: (FromJSON a, ToJSON a) => ServantError -> IO a +handleError (FailureResponse status _ b) = either fail (\r -> putStrLn ("Failure response (status " ++ show status ++ ")") >> prettyPrint r >> return r) (eitherDecode b) +handleError (DecodeFailure e _ b) = fail ("decode failure\n\n" ++ e ++ "\n\n" ++ showUnescaped b) +handleError (UnsupportedContentType ct b) = fail ("unsupported content type\n\n" ++ show ct ++ "\n" ++ show b) +handleError (InvalidContentTypeHeader h b) = fail ("unsupported content type type\n\n" ++ show h ++ "\n" ++ show b) +handleError (ConnectionError e) = fail ("connection error\n\n" ++ show e) + +showUnescaped :: Show a => a -> String +showUnescaped = replace [("\\n", "\n"), ("\\\"", "\"")] . show + +prettyPrint :: ToJSON a => a -> IO () +prettyPrint = putStrLn . showUnescaped . encodePretty + +replace :: [(String, String)] -> String -> String +replace assocs s = T.unpack $ foldr replace' (T.pack s) assocs' + where + assocs' :: [(Text, Text)] + assocs' = map (bimap T.pack T.pack) assocs + replace' :: (Text, Text) -> Text -> Text + replace' (a,b) = T.replace a b + +-- | Pretty-print the JSON encoding of the supplied value. +prettyPrintEncoding :: ToJSON a => a -> IO () +prettyPrintEncoding = putStrLn . showUnescaped . encodePretty + +-- | Current time. Not referentially transparent! +now :: () -> UTCTime +now _ = unsafePerformIO getCurrentTime diff --git a/src/Alerta/ServantExtras.hs b/src/Alerta/ServantExtras.hs new file mode 100644 --- /dev/null +++ b/src/Alerta/ServantExtras.hs @@ -0,0 +1,52 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +-------------------------------------------------------------------------------- +-- Module: Alerta.ServantExtras +-- +-- Additions to Servant needed to cope with the peculiarities of +-- alerta's REST API. +-------------------------------------------------------------------------------- +module Alerta.ServantExtras + ( FieldQueries + ) where + +import Alerta.Types (FieldQuery, MatchType(..)) + +import Data.List +import Data.Monoid ((<>)) +import Data.Proxy +import qualified Data.Text as T + +import Servant.Common.Req (Req, appendToQueryString) +import Servant.Client +import Servant.API ((:>)) +import Web.HttpApiData + +-- | We need this because Alerta for some reason requires `field` and `field!` +-- parameters to be joined together with a comma rather than passed in the +-- usual way. +instance {-# OVERLAPPABLE #-} ToHttpApiData a => ToHttpApiData [a] where + toQueryParam = T.intercalate "," . map toQueryParam + +data FieldQueries + +instance HasClient api => HasClient (FieldQueries :> api) where + type Client (FieldQueries :> api) = [FieldQuery] -> Client api + + clientWithRoute Proxy req fqs = + clientWithRoute (Proxy :: Proxy api) $ foldl' (flip f) req fqs where + + f :: FieldQuery -> Req -> Req + f (attr, txt, t, b) = appendToQueryString k (Just v) where + k = toUrlPiece attr <> suffix + v = prefix <> txt + suffix = if b then "" else "!" + prefix = case t of + Regex -> "~" + Literal -> "" diff --git a/src/Alerta/Types.hs b/src/Alerta/Types.hs new file mode 100644 --- /dev/null +++ b/src/Alerta/Types.hs @@ -0,0 +1,1095 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +-------------------------------------------------------------------------------- +-- | +-- Module: Alerta.Types +-- +-- Types used by the alerta bindings. +-- This includes request and return parameter types, as well as type synonyms used +-- to help document the bindings. +-- +-- A record whose name ends in \"Resp\" indicates a response from the server. +-- A record whose name ends in \"Info\" indicates data contained within +-- responses from the server. +-------------------------------------------------------------------------------- +module Alerta.Types + ( + -- ** General domain terms + Resource + , Event + , Service + , Environment + , Group + , Origin + , AlertType + , UserName + , CustomerName + , Tag + , Email + , Password + , Provider + , UUID + , Href + -- ** Query and sorting options + , ShouldReverse + , Limit + , PageNo + , QueryString + , IsRepeat + -- ** Field queries + , FieldQuery + , MatchType(..) + , (=.), (!=), (~.), (!~) + -- ** Generic response + , Resp(..) + -- ** Alerts + , Severity(..) + , Status(..) + , TrendIndication(..) + , Alert(..) + , mkAlert + , AlertInfo(..) + , AlertAttr(..) + , QueryAttr(..) + , HistoryItem(..) + , ExtendedHistoryItem(..) + , Tags(..) + , Attributes(..) + , StatusChange(..) + , CreateAlertResp(..) + , AlertResp(..) + , AlertsResp(..) + , AlertCountResp(..) + , ResourceInfo(..) + , Top10Info(..) + , Top10Resp(..) + , AlertHistoryResp(..) + -- ** Environments + , EnvironmentInfo(..) + , EnvironmentsResp(..) + -- ** Services + , ServiceInfo(..) + , ServicesResp(..) + -- ** Blackouts + , Blackout(..) + , blackout + , BlackoutInfo(..) + , BlackoutStatus(..) + , ExtendedBlackoutInfo(..) + , BlackoutResp(..) + , BlackoutsResp(..) + -- ** Heartbeats + , Heartbeat(..) + , HeartbeatInfo(..) + , CreateHeartbeatResp(..) + , HeartbeatResp(..) + , HeartbeatsResp(..) + -- ** API keys + , ApiKey(..) + , CreateApiKey(..) + , ApiKeyType(..) + , ApiKeyInfo(..) + , CreateApiKeyResp(..) + , ApiKeysResp(..) + -- ** Users + , User(..) + , user + , UserAttr(..) + , IsEmpty(..) + , emptyUserAttr + , checkNonempty + , withUserName + , withUserLogin + , withUserPassword + , withUserProvider + , withUserText + , withUserEmailVerified + , UserInfo(..) + , RoleType(..) + , ExtendedUserInfo(..) + , UserResp(..) + , UsersResp(..) + -- ** Customers + , Customer(..) + , CustomerInfo(..) + , CustomerResp(..) + , CustomersResp(..) + ) where + +import Alerta.Util + +import Control.Applicative (empty) + +import Data.Aeson +import qualified Data.Aeson.Encoding as E +import Data.Aeson.Types +import Data.Aeson.TH +import Data.Coerce (coerce) +import Data.Default +import Data.Ix +import Data.Map (Map) +import Data.Monoid ((<>)) +import Data.String (IsString(..)) +import qualified Data.Text as T +import Data.Text (Text) +import Data.Time (UTCTime) + +import GHC.Generics + +import Web.HttpApiData + +type Resource = Text +type Event = Text +type Service = Text +type Environment = Text +type Group = Text +type Origin = Text +type AlertType = Text +type UserName = Text +type CustomerName = Text +type Tag = Text +type Email = Text -- TODO actual email type +type Password = Text +type Provider = Text -- TODO make into data type +type ShouldReverse = Bool -- ^ whether to reverse the order of a sort +type Limit = Int -- ^ maximum number of results to return (actually a positive int) +type PageNo = Int -- ^ what page of the results to return (actually a positive int) +type UUID = Text -- TODO actual UUID type? +type Href = Text -- TODO use URL type for hrefs +-- | This is a JSON document describing a Mongo query, +-- see http://docs.mongodb.org/manual/reference/operator/query/ +type QueryString = Text -- TODO should be JSON or an ADT representing a Mongo query +type IsRepeat = Bool +-- ^ true for duplicate, false if an alert is correlated (in which case alerta appends an item to +-- the history) + +-------------------------------------------------------------------------------- +-- Field queries +-------------------------------------------------------------------------------- + +type FieldQuery = (QueryAttr, Text, MatchType, Bool) + +-- | Matches can be either literal or regular expressions. +-- n.b. regexes are case-insensitive and are not anchored, +-- i.e. no need to write .*regex.* +data MatchType = Regex | Literal deriving (Eq, Enum, Show, Read, Generic) + +-- | Convenient syntax for the four types of field queries +-- viz. literal, negated literal, regex, negated regex. +(=.), (!=), (~.), (!~) :: QueryAttr -> Text -> FieldQuery +k =. v = (k, v, Literal, True) +k != v = (k, v, Literal, False) +k ~. v = (k, v, Regex, True) +k !~ v = (k, v, Regex, False) + +-- | These are the valid keys for use in field queries. +-- +-- NB no 'id', 'repeat' or 'duplicateCount' as these have special handling. +data QueryAttr = + EventQueryAttr + | EnvironmentQueryAttr + | SeverityQueryAttr + | CorrelateQueryAttr + | StatusQueryAttr + | ServiceQueryAttr + | GroupQueryAttr + | ValueQueryAttr + | TextQueryAttr + | TagsQueryAttr + | AttributesQueryAttr + | OriginQueryAttr + | TypeQueryAttr + | CreateTimeQueryAttr + | TimeoutQueryAttr + | RawDataQueryAttr + | CustomerQueryAttr + | RepeatQueryAttr + | PreviousSeverityQueryAttr + | TrendIndicationQueryAttr + | ReceiveTimeQueryAttr + | LastReceiveIdQueryAttr + | LastReceiveTimeQueryAttr + | HistoryQueryAttr + | HrefQueryAttr + deriving (Eq, Enum, Show, Generic) + +instance IsString QueryAttr where + fromString "event" = EventQueryAttr + fromString "environment" = EnvironmentQueryAttr + fromString "severity" = SeverityQueryAttr + fromString "correlate" = CorrelateQueryAttr + fromString "status" = StatusQueryAttr + fromString "service" = ServiceQueryAttr + fromString "group" = GroupQueryAttr + fromString "value" = ValueQueryAttr + fromString "text" = TextQueryAttr + fromString "tags" = TagsQueryAttr + fromString "attributes" = AttributesQueryAttr + fromString "origin" = OriginQueryAttr + fromString "type" = TypeQueryAttr + fromString "createTime" = CreateTimeQueryAttr + fromString "timeout" = TimeoutQueryAttr + fromString "rawData" = RawDataQueryAttr + fromString "customer" = CustomerQueryAttr + fromString "repeat" = RepeatQueryAttr + fromString "previousSeverity" = PreviousSeverityQueryAttr + fromString "trendIndication" = TrendIndicationQueryAttr + fromString "receiveTime" = ReceiveTimeQueryAttr + fromString "lastReceiveId" = LastReceiveIdQueryAttr + fromString "lastReceiveTime" = LastReceiveTimeQueryAttr + fromString "history" = HistoryQueryAttr + fromString "href" = HrefQueryAttr + fromString other = error $ "\"" ++ other ++ "\" is not a valid QueryAttr" + +instance ToHttpApiData QueryAttr where + toQueryParam = T.pack . uncapitalise . onCamelComponents (dropRight 2) . show + +-- | Alert severity +data Severity = + Unknown + | Trace -- ^ 8 (grey) + | Debug -- ^ 7 (purple) + | Informational -- ^ 6 (green) + | Ok -- ^ 5 (green) + | Normal -- ^ 5 (green) + | Cleared -- ^ 5 (green) + | Indeterminate -- ^ 5 (silver) + | Warning -- ^ 4 (blue) + | Minor -- ^ 3 (yellow) + | Major -- ^ 2 (orange) + | Critical -- ^ 1 (red) + | Security -- ^ 0 (black) + deriving (Eq, Ord, Bounded, Enum, Ix, Show, Read, Generic) + +instance ToHttpApiData Severity where + toUrlPiece = T.pack . show + +instance ToJSONKey Severity where + toJSONKey = toJSONKeyText (T.toLower . T.pack . show) + +instance FromJSONKey Severity where + fromJSONKey = FromJSONKeyTextParser $ \case + "security" -> pure Security + "critical" -> pure Critical + "major" -> pure Major + "minor" -> pure Minor + "warning" -> pure Warning + "indeterminate" -> pure Indeterminate + "cleared" -> pure Cleared + "normal" -> pure Normal + "ok" -> pure Ok + "informational" -> pure Informational + "debug" -> pure Debug + "trace" -> pure Trace + "unknown" -> pure Unknown + other -> fail $ "Could not parse key \"" ++ T.unpack other ++ "\" as Severity" + +-- | Status of an alert. +data Status = -- Status Code + OpenStatus -- ^ status code 1 + | AssignStatus -- ^ status code 2 + | AckStatus -- ^ status code 3 + | ClosedStatus -- ^ status code 4 + | ExpiredStatus -- ^ status code 5 + | UnknownStatus -- ^ status code 9 + deriving (Eq, Ord, Bounded, Enum, Ix, Show, Read, Generic) + +instance ToHttpApiData Status where + toUrlPiece = showTextLowercase + +instance ToJSONKey Status where + toJSONKey = toJSONKeyText (T.toLower . T.pack . show) + +instance FromJSONKey Status where + fromJSONKey = FromJSONKeyTextParser $ \case + "open" -> pure OpenStatus + "assign" -> pure AssignStatus + "ack" -> pure AckStatus + "closed" -> pure ClosedStatus + "expired" -> pure ExpiredStatus + "unknown" -> pure UnknownStatus + other -> fail $ "Could not parse key \"" ++ T.unpack other ++ "\" as Status" + +data TrendIndication = NoChange | LessSevere | MoreSevere + deriving (Eq, Ord, Bounded, Enum, Ix, Show, Generic) + +instance FromHttpApiData TrendIndication where + parseQueryParam = parseBoundedTextData + +-------------------------------------------------------------------------------- +-- Basic response +-------------------------------------------------------------------------------- + +-- | This type is used for basic responses that have no content beyond whether they succeeded or +-- failed with an error message. +data Resp = OkResp | ErrorResp { respMessage :: Text } + deriving (Eq, Show, Generic) + +-------------------------------------------------------------------------------- +-- Alerts +-------------------------------------------------------------------------------- + +-- | Data required to create (post) an alert. +data Alert = Alert { + alertResource :: Resource + , alertEvent :: Event + , alertEnvironment :: Maybe Environment + , alertSeverity :: Maybe Severity + , alertCorrelate :: Maybe [Event] + , alertStatus :: Maybe Status + , alertService :: Maybe [Service] + , alertGroup :: Maybe Group -- ^ defaults to @Misc@ + , alertValue :: Maybe Value -- ^ defaults to @n/a@ + , alertText :: Maybe Text + , alertTags :: Maybe [Tag] + , alertAttributes :: Maybe (Map Text Text) + -- Attribute keys must not contain "." or "$" + -- note that key "ip" will be overwritten + , alertOrigin :: Maybe Origin -- ^ defaults to prog\/machine ('%s\/%s' % (os.path.basename(sys.argv[0]), platform.uname()[1])) + , alertType :: Maybe AlertType -- ^ defaults to @exceptionAlert@ + , alertCreateTime :: Maybe UTCTime -- ^ defaults to @utcnow()@ + , alertTimeout :: Maybe Int -- ^ in seconds; defaults to 86400 (24 hours) + , alertRawData :: Maybe Text + , alertCustomer :: Maybe CustomerName + } deriving (Eq, Show, Generic) + +-- | Create an alert with just the mandatory fields. +mkAlert :: Resource -> Event -> Service -> Alert +mkAlert r e s = Alert { + alertResource = r + , alertEvent = e + -- supposed to be optional, but RejectPolicy plugin requires it to be one of ALLOWED_ENVIRONMENTS + , alertEnvironment = Just "Development" + , alertSeverity = Nothing + , alertCorrelate = Nothing + , alertStatus = Nothing + -- supposed to be optional, but RejectPolicy requires it to be set + , alertService = Just [s] + , alertGroup = Nothing + , alertValue = Nothing + , alertText = Nothing + , alertTags = Nothing + , alertAttributes = Nothing + , alertOrigin = Nothing + , alertType = Nothing + , alertCreateTime = Nothing + , alertTimeout = Nothing + , alertRawData = Nothing + , alertCustomer = Nothing + } + +-- | Data returned from the server about an alert +data AlertInfo = AlertInfo { + alertInfoId :: UUID + , alertInfoResource :: Resource + , alertInfoEvent :: Event + , alertInfoEnvironment :: Environment -- ^ defaults to empty string + , alertInfoSeverity :: Maybe Severity + , alertInfoCorrelate :: [Event] + , alertInfoStatus :: Maybe Status + , alertInfoService :: [Service] + , alertInfoGroup :: Group -- ^ defaults to @misc@ + , alertInfoValue :: Value -- ^ defaults to @n/a@ + , alertInfoText :: Text -- ^ defaults to empty string + , alertInfoTags :: [Tag] + , alertInfoAttributes :: Map Text Text -- ^ Attribute keys must not contain "." or "$" + , alertInfoOrigin :: Origin -- ^ defaults to prog\/machine + , alertInfoType :: AlertType -- ^ defaults to @exceptionAlert@ + , alertInfoCreateTime :: UTCTime + , alertInfoTimeout :: Int + , alertInfoRawData :: Maybe Text + , alertInfoCustomer :: Maybe CustomerName + , alertInfoDuplicateCount :: Maybe Int + , alertInfoRepeat :: Maybe Bool + , alertInfoPreviousSeverity :: Maybe Severity + , alertInfoTrendIndication :: Maybe TrendIndication + , alertInfoReceiveTime :: UTCTime + , alertInfoLastReceiveId :: Maybe UUID + , alertInfoLastReceiveTime :: UTCTime + , alertInfoHistory :: [HistoryItem] + , alertInfoHref :: Href + } deriving (Eq, Show, Generic) + +-- | Alert attributes, used for sorting, grouping and for field-based queries +data AlertAttr = + IdAlertAttr + | ResourceAlertAttr + | EventAlertAttr + | EnvironmentAlertAttr + | SeverityAlertAttr + | CorrelateAlertAttr + | StatusAlertAttr + | ServiceAlertAttr + | GroupAlertAttr + | ValueAlertAttr + | TextAlertAttr + | TagsAlertAttr + | AttributesAlertAttr + | OriginAlertAttr + | TypeAlertAttr + | CreateTimeAlertAttr + | TimeoutAlertAttr + | RawDataAlertAttr + | CustomerAlertAttr + | DuplicateCountAlertAttr + | RepeatAlertAttr + | PreviousSeverityAlertAttr + | TrendIndicationAlertAttr + | ReceiveTimeAlertAttr + | LastReceiveIdAlertAttr + | LastReceiveTimeAlertAttr + | HistoryAlertAttr + | HrefAlertAttr + deriving (Eq, Enum, Show, Generic) + +instance IsString AlertAttr where + fromString "id" = IdAlertAttr + fromString "resource" = ResourceAlertAttr + fromString "event" = EventAlertAttr + fromString "environment" = EnvironmentAlertAttr + fromString "severity" = SeverityAlertAttr + fromString "correlate" = CorrelateAlertAttr + fromString "status" = StatusAlertAttr + fromString "service" = ServiceAlertAttr + fromString "group" = GroupAlertAttr + fromString "value" = ValueAlertAttr + fromString "text" = TextAlertAttr + fromString "tags" = TagsAlertAttr + fromString "attributes" = AttributesAlertAttr + fromString "origin" = OriginAlertAttr + fromString "type" = TypeAlertAttr + fromString "createTime" = CreateTimeAlertAttr + fromString "timeout" = TimeoutAlertAttr + fromString "rawData" = RawDataAlertAttr + fromString "customer" = CustomerAlertAttr + fromString "duplicateCount" = DuplicateCountAlertAttr + fromString "repeat" = RepeatAlertAttr + fromString "previousSeverity" = PreviousSeverityAlertAttr + fromString "trendIndication" = TrendIndicationAlertAttr + fromString "receiveTime" = ReceiveTimeAlertAttr + fromString "lastReceiveId" = LastReceiveIdAlertAttr + fromString "lastReceiveTime" = LastReceiveTimeAlertAttr + fromString "history" = HistoryAlertAttr + fromString "href" = HrefAlertAttr + fromString other = error $ "\"" ++ other ++ "\" is not a valid AlertAttr" + +instance ToHttpApiData AlertAttr where + toQueryParam = T.pack . uncapitalise . onCamelComponents (dropRight 2) . show + +data HistoryItem = StatusHistoryItem { + historyItemEvent :: Event + , historyItemStatus :: Status + , historyItemText :: Text + , historyItemId :: UUID + , historyItemUpdateTime :: UTCTime + } | SeverityHistoryItem { + historyItemEvent :: Event + , historyItemSeverity :: Severity + , historyItemText :: Text + , historyItemId :: UUID + , historyItemUpdateTime :: UTCTime + , historyItemValue :: Value + } deriving (Eq, Show, Generic) + +-- | When performing an alert history query an enriched version of the alert history is returned with extra fields. +data ExtendedHistoryItem = StatusExtendedHistoryItem { + statusExtendedHistoryItemId :: UUID + , statusExtendedHistoryItemResource :: Resource + , statusExtendedHistoryItemEvent :: Event + , statusExtendedHistoryItemEnvironment :: Environment + , statusExtendedHistoryItemStatus :: Status + , statusExtendedHistoryItemService :: [Service] -- ^ why this is an array I do not know + , statusExtendedHistoryItemGroup :: Group + , statusExtendedHistoryItemText :: Text + , statusExtendedHistoryItemTags :: [Tag] + , statusExtendedHistoryItemAttributes :: Map Text Text + , statusExtendedHistoryItemOrigin :: Origin + , statusExtendedHistoryItemUpdateTime :: UTCTime + , statusExtendedHistoryItemCustomer :: Maybe CustomerName + } | SeverityExtendedHistoryItem { + severityExtendedHistoryItemId :: UUID + , severityExtendedHistoryItemResource :: Resource + , severityExtendedHistoryItemEvent :: Event + , severityExtendedHistoryItemEnvironment :: Environment + , severityExtendedHistoryItemSeverity :: Severity + , severityExtendedHistoryItemService :: [Service] -- ^ why this is an array I do not know + , severityExtendedHistoryItemGroup :: Group + , severityExtendedHistoryItemValue :: Value + , severityExtendedHistoryItemText :: Text + , severityExtendedHistoryItemTags :: [Tag] + , severityExtendedHistoryItemAttributes :: Map Text Text + , severityExtendedHistoryItemOrigin :: Origin + , severityExtendedHistoryItemUpdateTime :: UTCTime + , severityExtendedHistoryItemCustomer :: Maybe CustomerName + } deriving (Eq, Show, Generic) + +newtype Tags = Tags { tags :: [Tag] } deriving (Eq, Show, Generic) + +-- | Attributes are key-value pairs that can be attached to an alert. +newtype Attributes = Attributes { attributes :: Map Text Text } deriving (Eq, Show, Generic) + +data StatusChange = StatusChange { + statusChangeStatus :: Status -- docs say not "unknown" but the api allows it + -- (in fact any text is accepted - but our parsing code need to be able + -- to read it back from the alert history) + , statusChangeText :: Maybe Text + } deriving (Eq, Show, Generic) + +data CreateAlertResp = OkCreateAlertResp { + okCreateAlertRespId :: UUID + , okCreateAlertRespAlert :: Maybe AlertInfo -- ^ not present if rate limited or in blackout + , okCreateAlertRespMessage :: Maybe Text -- ^ present when rate limited or in blackout + } | ErrorCreateAlertResp { + errorCreateAlertRespMessage :: Text + } deriving (Eq, Show, Generic) + +data AlertResp = OkAlertResp { + okAlertRespAlert :: AlertInfo + , okAlertRespTotal :: Int + } | ErrorAlertResp { + errorAlertRespMessage :: Text + } deriving (Eq, Show, Generic) + +data AlertsResp = OkAlertsResp { + okAlertsRespAlerts :: [AlertInfo] + , okAlertsRespTotal :: Int + , okAlertsRespPage :: PageNo + , okAlertsRespPageSize :: Int + , okAlertsRespPages :: Int + , okAlertsRespMore :: Bool + , okAlertsRespSeverityCounts :: Maybe (Map Severity Int) + , okAlertsRespStatusCounts :: Maybe (Map Status Int) + , okAlertsRespLastTime :: UTCTime + , okAlertsRespAutoRefresh :: Bool + , okAlertsRespMessage :: Maybe Text + } | ErrorAlertsResp { + errorAlertsRespMessage :: Text + } deriving (Eq, Show, Generic) + +data AlertCountResp = OkAlertCountResp { + okAlertCountRespTotal :: Int + , okAlertCountRespSeverityCounts :: Int + , okAlertCountRespStatusCounts :: Int + , okAlertCountRespMessage :: Maybe Text + } | ErrorAlertCountResp { + errorAlertCountRespMessage :: Text + } deriving (Eq, Show, Generic) + +data ResourceInfo = ResourceInfo { + resourceInfoId :: UUID + , resourceInfoResource :: Resource + , resourceInfoHref :: Href + } deriving (Eq, Show, Generic) + +-- | This also has a field corresponding to the "group-by" query parameter used +-- i.e. if you group by origin, then the result will have an "origin" field. +-- +-- This dependently-typed feature is not currently captured in the Haskell types. +data Top10Info = Top10Info { + top10InfoCount :: Int + , top10InfoDuplicateCount :: Int + , top10InfoEnvironments :: [Environment] + , top10InfoServices :: [Service] + , top10InfoResources :: [ResourceInfo] + } deriving (Eq, Show, Generic) + +data Top10Resp = OkTop10Resp { + okTop10RespTop10 :: [Top10Info] + , okTop10RespTotal :: Int + , okTop10RespMessage :: Maybe Text + } | ErrorTop10Resp { + errorTop10RespMessage :: Text + } deriving (Eq, Show, Generic) + +data AlertHistoryResp = OkAlertHistoryResp { + okAlertHistoryRespHistory :: [ExtendedHistoryItem] + , okAlertHistoryRespLastTime :: UTCTime + , okAlertHistoryRespMessage :: Maybe Text + } | ErrorAlertHistoryResp { + errorAlertHistoryResp :: Text + } deriving (Eq, Show, Generic) + +-------------------------------------------------------------------------------- +-- Environments +-------------------------------------------------------------------------------- + +data EnvironmentInfo = EnvironmentInfo { + environmentInfoCount :: Int + , environmentInfoEnvironment :: Environment + } deriving (Eq, Show, Generic) + +data EnvironmentsResp = OkEnvironmentsResp { + okEnvironmentsRespMessage :: Maybe Text + , okEnvironmentsRespTotal :: Int + , okEnvironmentsRespEnvironments :: [EnvironmentInfo] + } | ErrorEnvironmentsResp { + errorEnvironmentsRespMessage :: Text + } deriving (Eq, Show, Generic) + +-------------------------------------------------------------------------------- +-- Services +-------------------------------------------------------------------------------- + +data ServiceInfo = ServiceInfo { + serviceInfoCount :: Int + , serviceInfoEnvironment :: Environment + , serviceInfoService :: Service + } deriving (Eq, Show, Generic) + +data ServicesResp = OkServicesResp { + okServicesRespTotal :: Int + , okServicesRespServices :: [ServiceInfo] + , okServicesRespMessage :: Maybe Text + } | ErrorServicesResp { + errorServicesRespMessage :: Text + } deriving (Eq, Show, Generic) + +-------------------------------------------------------------------------------- +-- Blackouts +-------------------------------------------------------------------------------- + +data Blackout = Blackout { + blackoutEnvironment :: Environment + , blackoutResource :: Maybe Resource + , blackoutService :: Maybe Service + , blackoutEvent :: Maybe Event + , blackoutGroup :: Maybe Group + , blackoutTags :: Maybe [Tag] + , blackoutStartTime :: Maybe UTCTime -- ^ defaults to now + , blackoutEndTime :: Maybe UTCTime -- ^ defaults to start + duration + , blackoutDuration :: Maybe Int -- ^ in seconds; can be calculated from start and end, or else defaults to BLACKOUT_DURATION + } deriving (Eq, Show, Generic) + +-- | Create a blackout with only the mandatory fields +blackout :: Environment -> Blackout +blackout env = Blackout env Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing + +-- | A note on blackout priorities: +-- +-- Priority is +-- +-- 1. by default +-- +-- 2. if resource and not event present +-- +-- 3. if service present +-- +-- 4. if event and not resource +-- +-- 5. if group present +-- +-- 6. if resource and event present +-- +-- 7. if tags present +-- +-- Somewhat bizarrely, the saved blackout only includes an attribute +-- +-- {resource,service,event,group,tags} +-- +-- if it was used to deduce the priority, +-- i.e. a priority 6 blackout will have resource and event attributes, +-- but no tags attribute, even if it was supplied when it was created. +data BlackoutInfo = BlackoutInfo { + blackoutInfoId :: UUID + , blackoutInfoPriority :: Int + , blackoutInfoEnvironment :: Environment + , blackoutInfoResource :: Maybe Resource + , blackoutInfoService :: Maybe [Service] + , blackoutInfoEvent :: Maybe Event + , blackoutInfoGroup :: Maybe Group + , blackoutInfoTags :: Maybe [Tag] + , blackoutInfoCustomer :: Maybe CustomerName + , blackoutInfoStartTime :: UTCTime -- ^ defaults to now + , blackoutInfoEndTime :: UTCTime -- ^ defaults to start + duration + , blackoutInfoDuration :: Int -- ^ can be calculated from start and end, or else defaults to BLACKOUT_DURATION + } deriving (Eq, Show, Generic) + +data BlackoutStatus = Expired | Pending | Active deriving (Eq, Ord, Bounded, Enum, Ix, Show, Generic) + +data ExtendedBlackoutInfo = ExtendedBlackoutInfo { + extendedBlackoutInfoId :: UUID + , extendedBlackoutInfoPriority :: Int -- see comment above + , extendedBlackoutInfoEnvironment :: Environment + , extendedBlackoutInfoResource :: Maybe Resource + , extendedBlackoutInfoService :: Maybe [Service] + , extendedBlackoutInfoEvent :: Maybe Event + , extendedBlackoutInfoGroup :: Maybe Group + , extendedBlackoutInfoTags :: Maybe [Tag] + , extendedBlackoutInfoCustomer :: Maybe CustomerName + , extendedBlackoutInfoStartTime :: UTCTime -- defaults to now + , extendedBlackoutInfoEndTime :: UTCTime -- defaults to start + duration + , extendedBlackoutInfoDuration :: Int -- can be calculated from start and end, or else defaults to BLACKOUT_DURATION + , extendedBlackoutInfoRemaining :: Int + , extendedBlackoutInfoStatus :: BlackoutStatus + } deriving (Eq, Show, Generic) + +data BlackoutResp = OkBlackoutResp { + okBlackoutRespId :: UUID + , okBlackoutRespBlackout :: BlackoutInfo + } | ErrorBlackoutResp { + errorBlackoutRespMessage :: Text + } deriving (Eq, Show, Generic) + +data BlackoutsResp = OkBlackoutsResp { + okBlackoutsRespTotal :: Int + , okBlackoutsRespBlackouts :: [ExtendedBlackoutInfo] + , okBlackoutsRespMessage :: Maybe Text + , okBlackoutsRespTime :: UTCTime + } | ErrorBlackoutsResp { + errorBlackoutsRespMessage :: Text + } deriving (Eq, Show, Generic) + + +-------------------------------------------------------------------------------- +-- Heartbeats +-------------------------------------------------------------------------------- + +-- | Data needed to create a heartbeat +data Heartbeat = Heartbeat { + heartbeatOrigin :: Maybe Origin -- defaults to prog/nodename + , heartbeatTags :: [Tag] + , heartbeatCreateTime :: Maybe UTCTime + , heartbeatTimeout :: Maybe Int -- seconds + , heartbeatCustomer :: Maybe CustomerName -- if not admin, gets overwritten + } deriving (Eq, Show, Generic, Default) + +-- | Information returned from the server about a heartbeat +data HeartbeatInfo = HeartbeatInfo { + heartbeatInfoCreateTime :: UTCTime + , heartbeatInfoCustomer :: Maybe CustomerName + , heartbeatInfoHref :: Href + , heartbeatInfoId :: UUID + , heartbeatInfoOrigin :: Origin + , heartbeatInfoReceiveTime :: UTCTime + , heartbeatInfoTags :: [Tag] + , heartbeatInfoTimeout :: Int + , heartbeatInfoType :: Text + } deriving (Eq, Show, Generic) + +data CreateHeartbeatResp = OkCreateHeartbeatResp { + createHeartbeatRespId :: UUID + , createHeartbeatRespHeartbeat :: HeartbeatInfo + } | ErrorCreateHeartbeatResp { + createHeartbeatRespMessage :: Text + } deriving (Eq, Show, Generic) + +data HeartbeatResp = OkHeartbeatResp { + heartbeatRespHeartbeat :: HeartbeatInfo + , heartbeatRespTotal :: Int + } | ErrorHeartbeatResp { + heartbeatRespMessage :: Text + } deriving (Eq, Show, Generic) + +data HeartbeatsResp = OkHeartbeatsResp { + heartbeatsRespHeartbeats :: [HeartbeatInfo] + , heartbeatsRespTime :: Maybe UTCTime + , heartbeatsRespTotal :: Int + , heartbeatsRespMessage :: Maybe Text + } | ErrorHeartbeatsResp { + heartbeatsRespErrorMessage :: Text + } deriving (Eq, Show, Generic) + + +-------------------------------------------------------------------------------- +-- API keys +-------------------------------------------------------------------------------- + +-- when using admin credentials, user must be present, or associated with account + +-- | 40-char UTF8 + +-- TODO smart constructor +data ApiKey = ApiKey { unApiKey :: !Text } + deriving (Eq, Show, Generic) + +instance IsString ApiKey where + fromString = ApiKey . T.pack + +instance FromJSON ApiKey where + parseJSON = withText "API key" (pure . ApiKey) + +instance ToJSON ApiKey where + toJSON (ApiKey k) = String k + {-# INLINE toJSON #-} + + toEncoding (ApiKey k) = E.text k + {-# INLINE toEncoding #-} + +instance ToHttpApiData ApiKey where + toUrlPiece (ApiKey k) = k + +-- | Data needed to create an API key +data CreateApiKey = CreateApiKey { + createApiKeyUser :: Maybe Email -- ^ only read if authorised as admin, defaults to current user + , createApiKeyCustomer :: Maybe CustomerName -- ^ only read if authorised as admin, defaults to current customer + , createApiKeyType :: Maybe ApiKeyType -- ^ defaults to read-only + , createApiKeyText :: Maybe Text -- ^ defaults to "API Key for $user" + } deriving (Eq, Show, Generic, Default) + +data ApiKeyType = ReadOnly | ReadWrite deriving (Eq, Ord, Bounded, Enum, Ix, Generic) + +instance Show ApiKeyType where + show ReadWrite = "read-write" + show ReadOnly = "read-only" + +instance ToJSON ApiKeyType where + toJSON = genericToJSON $ defaultOptions { constructorTagModifier = camelTo2 '-'} + +instance FromJSON ApiKeyType where + parseJSON = genericParseJSON $ defaultOptions { constructorTagModifier = camelTo2 '-'} + +-- | Information returned from the server about an API key +data ApiKeyInfo = ApiKeyInfo { + apiKeyInfoUser :: Email + , apiKeyInfoKey :: ApiKey + , apiKeyInfoType :: ApiKeyType + , apiKeyInfoText :: Text + , apiKeyInfoExpireTime :: UTCTime + , apiKeyInfoCount :: Int -- number of times used + , apiKeyInfoLastUsedTime :: Maybe UTCTime + , apiKeyInfoCustomer :: Maybe CustomerName + } deriving (Eq, Show, Generic) + +data CreateApiKeyResp = OkCreateApiKeyResp { + okCreateApiKeyRespKey :: ApiKey + , okCreateApiKeyRespData :: ApiKeyInfo + } | ErrorCreateApiKeyResp { + errorCreateApiKeyRespMessage :: Text + } deriving (Eq, Show, Generic) + +data ApiKeysResp = OkApiKeysResp { + okApiKeysRespKeys :: [ApiKeyInfo] + , okApiKeysRespTotal :: Int + , okApiKeysRespTime :: UTCTime + , okApiKeysRespMessage :: Maybe Text + } | ErrorApiKeysResp { + errorApiKeysRespMessage :: Text + } deriving (Eq, Show, Generic) + +-------------------------------------------------------------------------------- +-- Users +-------------------------------------------------------------------------------- + +-- alerta doesn't require login, password but returns a 500 if they are missing +-- yay, cowboy coding + +-- Data needed to create a user +data User = User { + userName :: UserName + , userLogin :: Email + , userPassword :: Password + , userProvider :: Maybe Provider + , userText :: Maybe Text + , userEmailVerified :: Maybe Bool + } deriving (Show, Generic) + +-- | Create a user with just the mandatory fields. +user :: UserName -> Email -> Password -> User +user name login password = User name login password Nothing Nothing Nothing + +data IsEmpty = Empty | Nonempty | UnknownIfEmpty + +-- | User attributes, used in updating a user. +-- It's an error to update a user with all attributes missing. +-- +-- We track whether at least one attribute has been set with a phantom type. +-- +-- Alerta bugs: +-- +-- * can't update password without also passing provider=basic +-- as alerta checks the update message, not the user. +-- +-- * can't set email_verified to false without providing another parameter. +-- +-- The helper functions "withUserName" etc. can be used in conjunction with +-- the default empty "UserAttr" to build up a nonempty "UserAttr". + +data UserAttr (u :: IsEmpty) = UserAttr { + userAttrName :: Maybe UserName + , userAttrLogin :: Maybe Email + , userAttrPassword :: Maybe Password + , userAttrProvider :: Maybe Provider + , userAttrText :: Maybe Text + , userAttrEmail_verified :: Maybe Bool + } deriving (Eq, Show, Generic) + +emptyUserAttr :: UserAttr 'Empty +emptyUserAttr = UserAttr Nothing Nothing Nothing Nothing Nothing Nothing + +checkNonempty :: UserAttr u -> Either (UserAttr 'Empty) (UserAttr 'Nonempty) +checkNonempty a@(UserAttr Nothing Nothing Nothing Nothing Nothing Nothing) = Left $ coerce a +checkNonempty a = Right $ coerce a + +instance Default (UserAttr 'Empty) where + def = emptyUserAttr + +-- TODO omitNothingFields doesn't work +instance ToJSON (UserAttr 'Nonempty) where + toJSON = genericToJSON $ defaultOptions { omitNothingFields = True } + + toEncoding (UserAttr n l pw pr t ev) = + pairs $ + "name" .= n <> + "login" .= l <> + "password" .= pw <> + "provider" .= pr <> + "text" .= t <> + "email_verified" .= ev + +instance FromJSON (UserAttr 'UnknownIfEmpty) where + parseJSON (Object v) = + UserAttr <$> + v .:? "name" <*> + v .:? "login" <*> + v .:? "password" <*> + v .:? "provider" <*> + v .:? "text" <*> + v .:? "email_verified" + parseJSON _ = empty + +-- TODO replace with lenses +withUserName :: UserAttr u -> UserName -> UserAttr 'Nonempty +withUserLogin :: UserAttr u -> Email -> UserAttr 'Nonempty +withUserPassword :: UserAttr u -> Password -> UserAttr 'Nonempty +withUserProvider :: UserAttr u -> Provider -> UserAttr 'Nonempty +withUserText :: UserAttr u -> Text -> UserAttr 'Nonempty +withUserEmailVerified :: UserAttr u -> Bool -> UserAttr u +withUserName u s = u { userAttrName = Just s } +withUserLogin u s = u { userAttrLogin = Just s } +-- sets the provider to basic to work around the bug mentioned above +withUserPassword u s = u { userAttrPassword = Just s, userAttrProvider = Just "basic" } +withUserProvider u s = u { userAttrProvider = Just s } +withUserText u s = u { userAttrText = Just s } +withUserEmailVerified u b = u { userAttrEmail_verified = Just b } + +data UserInfo = UserInfo { + userInfoCreateTime :: UTCTime + , userInfoId :: UUID + , userInfoName :: UserName + , userInfoProvider :: Provider + , userInfoLogin :: Email + , userInfoText :: Text + , userInfoEmail_verified :: Bool + } deriving (Show, Generic) + +data RoleType = UserRoleType | AdminRoleType + deriving (Eq, Ord, Bounded, Enum, Ix, Show, Generic) + +data ExtendedUserInfo = ExtendedUserInfo { + extendedUserInfoCreateTime :: UTCTime + , extendedUserInfoId :: UUID + , extendedUserInfoName :: UserName + , extendedUserInfoLogin :: Email + , extendedUserInfoProvider :: Provider + , extendedUserInfoRole :: RoleType + , extendedUserInfoText :: Text + , extendedUserInfoEmail_verified :: Bool + } deriving (Show, Generic) + +data UserResp = OkUserResp { + okUserRespId :: UUID + , okUserRespUser :: UserInfo + } | ErrorUserResp { + errorUserRespMessage :: Text + } deriving (Show, Generic) + +data UsersResp = OkUsersResp { + okUsersRespUsers :: [ExtendedUserInfo] + , okUsersRespTotal :: Int + , okUsersRespDomains :: [Text] -- allowed email domains + , okUsersRespGroups :: [Text] -- allowed Gitlab groups + , okUsersRespOrgs :: [Text] -- allowed Github orgs + , okUsersRespRoles :: Maybe [Text] -- allowed Keycloud roles + , okUsersRespTime :: UTCTime + , okUsersRespMessage :: Maybe Text + } | ErrorUsersResp { + errorUsersResp :: Text + } deriving (Show, Generic) + +-------------------------------------------------------------------------------- +-- Customers +-------------------------------------------------------------------------------- + +data Customer = Customer { + customerCustomer :: CustomerName + , customerMatch :: Text -- regex, apparently + } deriving (Show, Generic) + +data CustomerInfo = CustomerInfo { + customerInfoId :: UUID + , customerInfoCustomer :: CustomerName + , customerInfoMatch :: Text -- regex, apparently + } deriving (Show, Generic) + +data CustomerResp = OkCustomerResp { + okCustomerRespId :: UUID + , okCustomerRespCustomer :: CustomerInfo + } | ErrorCustomerResp { + errorCustomerRespMessage :: Text + } deriving (Show, Generic) + +data CustomersResp = OkCustomersResp { + okCustomersRespCustomers :: [CustomerInfo] + , okCustomersRespTotal :: Int + , okCustomersRespMessage :: Maybe Text + , okCustomersRespTime :: UTCTime + } | ErrorCustomersResp { + errorCustomersMessage :: Text + } deriving (Show, Generic) + +$( deriveJSON (toOpts 0 0 def) ''Severity ) +$( deriveJSON (toOpts 1 1 def) ''Status ) +$( deriveJSON (toOpts 1 1 def) ''Alert ) +$( deriveJSON (toOpts 0 0 def { unwrap = False }) ''Tags ) +$( deriveJSON (toOpts 0 0 def { unwrap = False }) ''Attributes ) +$( deriveJSON (toOpts 2 2 def) ''AlertAttr ) +$( deriveJSON (toOpts 2 2 def) ''AlertInfo ) +$( deriveJSON (toOpts 4 3 def) ''CreateAlertResp ) +$( deriveJSON (toOpts 3 2 def) ''AlertResp ) +$( deriveJSON (toOpts 3 2 def) ''AlertsResp ) +$( deriveJSON (toOpts 2 2 def) ''ResourceInfo ) +$( deriveJSON (toOpts 2 2 def) ''Top10Info ) +$( deriveJSON (toOpts 3 2 def) ''Top10Resp ) +$( deriveJSON (toOpts 4 3 def) ''AlertCountResp ) +$( deriveJSON (toOpts 4 3 def) ''AlertHistoryResp ) +$( deriveJSON (toOpts 2 2 def) ''StatusChange ) +$( deriveJSON (toOpts 2 1 def) ''Resp ) +$( deriveJSON (toOpts 0 0 def) ''TrendIndication ) +$( deriveJSON (toOpts 2 2 def { tag = "type" }) ''HistoryItem ) +$( deriveJSON (toOpts 4 3 def { tag = "type" }) ''ExtendedHistoryItem ) +$( deriveJSON (toOpts 2 2 def) ''EnvironmentInfo ) +$( deriveJSON (toOpts 3 2 def) ''EnvironmentsResp ) +$( deriveJSON (toOpts 2 2 def) ''ServiceInfo ) +$( deriveJSON (toOpts 3 2 def) ''ServicesResp ) +$( deriveJSON (toOpts 1 1 def) ''Blackout ) +$( deriveJSON (toOpts 2 2 def) ''BlackoutInfo ) +$( deriveJSON (toOpts 2 0 def) ''BlackoutStatus ) +$( deriveJSON (toOpts 3 3 def) ''ExtendedBlackoutInfo ) +$( deriveJSON (toOpts 3 2 def) ''BlackoutResp ) +$( deriveJSON (toOpts 3 2 def) ''BlackoutsResp ) +$( deriveJSON (toOpts 1 1 def) ''Heartbeat ) +$( deriveJSON (toOpts 2 2 def) ''HeartbeatInfo ) +$( deriveJSON (toOpts 3 3 def) ''CreateHeartbeatResp ) +$( deriveJSON (toOpts 2 2 def) ''HeartbeatResp ) +$( deriveJSON (toOpts 2 2 def) ''HeartbeatsResp ) +$( deriveJSON (toOpts 3 3 def) ''CreateApiKey ) +$( deriveJSON (toOpts 3 3 def) ''ApiKeyInfo ) +$( deriveJSON (toOpts 5 4 def) ''CreateApiKeyResp ) +$( deriveJSON (toOpts 4 3 def) ''ApiKeysResp ) +$( deriveJSON (toOpts 3 2 def) ''RoleType ) +$( deriveJSON (toOpts 1 1 def) ''User ) +$( deriveJSON (toOpts 2 2 def) ''UserInfo ) +$( deriveJSON (toOpts 3 3 def) ''ExtendedUserInfo ) +$( deriveJSON (toOpts 3 2 def) ''UserResp ) +$( deriveJSON (toOpts 3 2 def) ''UsersResp ) +$( deriveJSON (toOpts 1 1 def) ''Customer ) +$( deriveJSON (toOpts 2 2 def) ''CustomerInfo ) +$( deriveJSON (toOpts 3 2 def) ''CustomerResp ) +$( deriveJSON (toOpts 3 2 def) ''CustomersResp ) diff --git a/src/Alerta/Util.hs b/src/Alerta/Util.hs new file mode 100644 --- /dev/null +++ b/src/Alerta/Util.hs @@ -0,0 +1,65 @@ +-------------------------------------------------------------------------------- +-- | +-- Module: Alerta.Util +-- +-- Internal utilities used by the Alerta package. +-- e.g. Aeson helper functions. +-------------------------------------------------------------------------------- +module Alerta.Util + ( toOpts + , AesonOpts(..) + , showTextLowercase + , capitalise + , uncapitalise + , onCamelComponents + , dropRight + ) where + +import Data.Aeson.TH +import Data.Char +import Data.Default +import qualified Data.Text as T +import Data.Text (Text) + +data AesonOpts = AesonOpts { tag :: String, unwrap :: Bool } + +instance Default AesonOpts where + def = AesonOpts "status" True + +-- TODO increment num words dropped from fieldLabel when tag is set, otherwise don't use TaggedObject +toOpts :: Int -> Int -> AesonOpts -> Data.Aeson.TH.Options +toOpts k n (AesonOpts f u) = Data.Aeson.TH.Options { + fieldLabelModifier = uncapitalise . onCamelComponents (drop k) + , constructorTagModifier = uncapitalise . onCamelComponents (dropRight n) + , omitNothingFields = True + , allNullaryToStringTag = True + , unwrapUnaryRecords = u + , sumEncoding = TaggedObject { tagFieldName = f, contentsFieldName = "contents" } +} + +showTextLowercase :: Show a => a -> Text +showTextLowercase = T.toLower . T.pack . show + +uncapitalise :: String -> String +uncapitalise [] = [] +uncapitalise (h : t) = toLower h : t + +capitalise :: String -> String +capitalise [] = [] +capitalise (h : t) = toUpper h : t + +dropRight :: Int -> [a] -> [a] +dropRight n = reverse . drop n . reverse + +onCamelComponents :: ([String] -> [String]) -> String -> String +onCamelComponents f = concat . f. camelComponents + +camelComponents :: String -> [String] +camelComponents = go [] "" + where + go :: [String] -> String -> String -> [String] + go ws w (x:u:l:xs) | isUpper u && isLower l = go ((x:w):ws) [l, u] xs + go ws w (l:u:xs) | isUpper u && isLower l = go ((l:w):ws) [u] xs + go ws w (x:xs) = go ws (x:w) xs + go ws w "" = reverse (map reverse (w:ws)) +