{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE BangPatterns #-}
module Monitor.Configuration.Config where

import System.Console.ANSI
import System.IO (hFlush, stdout)

import Control.Concurrent
import Control.Concurrent.STM.TVar
import Control.Exception
import Control.Monad.IO.Class

import qualified Data.ByteString.Char8 as BSC
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HM
import Data.Time

import qualified Hasql.Connection as HaSQL

import Dhall ( Generic, auto, inputFile, FromDhall, Natural )
import Dhall.Deriving

logMessage :: (?mutex :: Mutexes) => MonadIO m => String -> m ()
logMessage :: String -> m ()
logMessage String
event = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar (Mutexes -> MVar ()
stdoutMutex ?mutex::Mutexes
Mutexes
?mutex)
  !UTCTime
time <- IO UTCTime
getCurrentTime
  [SGR] -> IO ()
setSGR [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Dull Color
Green]
  String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ (UTCTime -> String
forall a. Show a => a -> String
show UTCTime
time) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": "
  [SGR] -> IO ()
setSGR [ConsoleLayer -> SGR
SetDefaultColor ConsoleLayer
Foreground]
  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
event
  Handle -> IO ()
hFlush Handle
stdout
  MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar (Mutexes -> MVar ()
stdoutMutex ?mutex::Mutexes
Mutexes
?mutex) ()

data Mutexes = Mutexes {
    Mutexes -> MVar ()
stdoutMutex :: MVar ()
  } deriving (Mutexes -> Mutexes -> Bool
(Mutexes -> Mutexes -> Bool)
-> (Mutexes -> Mutexes -> Bool) -> Eq Mutexes
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Mutexes -> Mutexes -> Bool
$c/= :: Mutexes -> Mutexes -> Bool
== :: Mutexes -> Mutexes -> Bool
$c== :: Mutexes -> Mutexes -> Bool
Eq)

data Config = Config
  { Config -> String
configConnection :: String
  , Config -> [Int]
configChannels :: [Int]
  , Config -> Natural
configFrequency :: Natural
  , Config -> String
configAssertion :: String
  }
  deriving (Config -> Config -> Bool
(Config -> Config -> Bool)
-> (Config -> Config -> Bool) -> Eq Config
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Config -> Config -> Bool
$c/= :: Config -> Config -> Bool
== :: Config -> Config -> Bool
$c== :: Config -> Config -> Bool
Eq, Int -> Config -> String -> String
[Config] -> String -> String
Config -> String
(Int -> Config -> String -> String)
-> (Config -> String)
-> ([Config] -> String -> String)
-> Show Config
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Config] -> String -> String
$cshowList :: [Config] -> String -> String
show :: Config -> String
$cshow :: Config -> String
showsPrec :: Int -> Config -> String -> String
$cshowsPrec :: Int -> Config -> String -> String
Show, (forall x. Config -> Rep Config x)
-> (forall x. Rep Config x -> Config) -> Generic Config
forall x. Rep Config x -> Config
forall x. Config -> Rep Config x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Config x -> Config
$cfrom :: forall x. Config -> Rep Config x
Generic)
  deriving
    (InputNormalizer -> Decoder Config
(InputNormalizer -> Decoder Config) -> FromDhall Config
forall a. (InputNormalizer -> Decoder a) -> FromDhall a
autoWith :: InputNormalizer -> Decoder Config
$cautoWith :: InputNormalizer -> Decoder Config
FromDhall)
    via Codec (Dhall.Deriving.Field (SnakeCase <<< DropPrefix "config")) Config

-- NOTE: resultless is for periodic actions.
data Assertion = AssertNull | AssertNotNull | AssertTrue | AssertFalse | AssertZero | AssertResultless
  deriving (Assertion -> Assertion -> Bool
(Assertion -> Assertion -> Bool)
-> (Assertion -> Assertion -> Bool) -> Eq Assertion
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Assertion -> Assertion -> Bool
$c/= :: Assertion -> Assertion -> Bool
== :: Assertion -> Assertion -> Bool
$c== :: Assertion -> Assertion -> Bool
Eq, Int -> Assertion -> String -> String
[Assertion] -> String -> String
Assertion -> String
(Int -> Assertion -> String -> String)
-> (Assertion -> String)
-> ([Assertion] -> String -> String)
-> Show Assertion
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Assertion] -> String -> String
$cshowList :: [Assertion] -> String -> String
show :: Assertion -> String
$cshow :: Assertion -> String
showsPrec :: Int -> Assertion -> String -> String
$cshowsPrec :: Int -> Assertion -> String -> String
Show)

data Settings = Settings
  { Settings -> Connection
dbConnection :: HaSQL.Connection
  , Settings -> [Integer]
channels :: [Integer]
  , Settings -> Int
defaultFrequency :: Int
  , Settings -> Assertion
defaultAssertion :: Assertion
  , Settings -> String
telegramTokenVar :: String
  , Settings -> String
databaseDirectory :: FilePath
  , Settings -> TVar (HashMap String ThreadId)
jobQueue :: TVar (HashMap FilePath ThreadId)
  }

readAssertion :: String -> Assertion
readAssertion :: String -> Assertion
readAssertion String
"null" = Assertion
AssertNull
readAssertion String
"true" = Assertion
AssertTrue
readAssertion String
"false" = Assertion
AssertFalse
readAssertion String
"zero" = Assertion
AssertZero
readAssertion String
"resultless" = Assertion
AssertResultless
-- NOTE: mention in README.
readAssertion String
_ = Assertion
AssertNotNull

readSettings :: (?mutex :: Mutexes) => FilePath -> String -> FilePath -> IO (Maybe Settings)
readSettings :: String -> String -> String -> IO (Maybe Settings)
readSettings String
dbDir String
tokenVar String
configPath = do
  Either SomeException Config
cfg <- IO Config -> IO (Either SomeException Config)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO Config -> IO (Either SomeException Config))
-> IO Config -> IO (Either SomeException Config)
forall a b. (a -> b) -> a -> b
$ Decoder Config -> String -> IO Config
forall a. Decoder a -> String -> IO a
inputFile Decoder Config
forall a. FromDhall a => Decoder a
auto String
configPath
  case Either SomeException Config
cfg of
    Left SomeException
ex -> do
      String -> IO ()
forall (m :: * -> *).
(?mutex::Mutexes, MonadIO m) =>
String -> m ()
logMessage (String
"Config for " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
dbDir String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" cannot be read. See exception below.")
      String -> IO ()
putStrLn (String
"Exception: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SomeException -> String
forall a. Show a => a -> String
show @SomeException SomeException
ex)
      Maybe Settings -> IO (Maybe Settings)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Settings
forall a. Maybe a
Nothing
    Right Config{Natural
String
[Int]
configAssertion :: String
configFrequency :: Natural
configChannels :: [Int]
configConnection :: String
configAssertion :: Config -> String
configFrequency :: Config -> Natural
configChannels :: Config -> [Int]
configConnection :: Config -> String
..} -> do
      Either ConnectionError Connection
dbConnection <- Settings -> IO (Either ConnectionError Connection)
HaSQL.acquire (String -> Settings
BSC.pack String
configConnection)
      case Either ConnectionError Connection
dbConnection of
        Left ConnectionError
_ -> do
          String -> IO ()
forall (m :: * -> *).
(?mutex::Mutexes, MonadIO m) =>
String -> m ()
logMessage (String
"Config error: connection string for " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
dbDir String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" directory does not provide connection to any database")
          Maybe Settings -> IO (Maybe Settings)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Settings
forall a. Maybe a
Nothing
        Right Connection
conn -> do
          TVar (HashMap String ThreadId)
queue <- HashMap String ThreadId -> IO (TVar (HashMap String ThreadId))
forall a. a -> IO (TVar a)
newTVarIO HashMap String ThreadId
forall k v. HashMap k v
HM.empty
          Maybe Settings -> IO (Maybe Settings)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Settings -> IO (Maybe Settings))
-> (Settings -> Maybe Settings) -> Settings -> IO (Maybe Settings)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Settings -> Maybe Settings
forall a. a -> Maybe a
Just (Settings -> IO (Maybe Settings))
-> Settings -> IO (Maybe Settings)
forall a b. (a -> b) -> a -> b
$ Settings :: Connection
-> [Integer]
-> Int
-> Assertion
-> String
-> String
-> TVar (HashMap String ThreadId)
-> Settings
Settings
            { dbConnection :: Connection
dbConnection = Connection
conn
            , channels :: [Integer]
channels = (Int -> Integer) -> [Int] -> [Integer]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral [Int]
configChannels
            , defaultFrequency :: Int
defaultFrequency = Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
configFrequency
            , defaultAssertion :: Assertion
defaultAssertion = String -> Assertion
readAssertion String
configAssertion
            , telegramTokenVar :: String
telegramTokenVar = String
tokenVar
            , databaseDirectory :: String
databaseDirectory = String
dbDir
            , jobQueue :: TVar (HashMap String ThreadId)
jobQueue = TVar (HashMap String ThreadId)
queue
            }