blob: 51f6d9408e7b20d48e937863f32c304c8cc29870 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
|
{-# LANGUAGE ImportQualifiedPost #-}
-- Module : Hsm.Core.App
-- Maintainer : contact@pauloliver.dev
module Hsm.Core.App
( launch
)
where
import Control.Applicative ((<**>))
import Data.Aeson (FromJSON, Result (Error, Success), Value, fromJSON)
import Data.Aeson.Key (fromString)
import Data.Aeson.KeyMap (KeyMap, (!?))
import Data.Maybe (fromMaybe)
import Data.Text (pack, unpack)
import Data.Yaml (decodeFileThrow)
import Effectful.Log (LogLevel (LogInfo), Logger, readLogLevelEither, showLogLevel)
import Log.Backend.StandardOutput (withStdOutLogger)
import Options.Applicative qualified as P
import System.IO.Echo (withoutInputEcho)
data Options = Options String LogLevel
parser :: P.Parser Options
parser =
Options
<$> P.strOption
( P.help "Path to services config file"
<> P.short 'c'
<> P.long "config"
<> P.metavar "PATH"
<> P.value "config.yaml"
<> P.showDefault
)
<*> P.option
(P.eitherReader $ readLogLevelEither . pack)
( P.help "Log level"
<> P.short 'l'
<> P.long "log-level"
<> P.metavar "LEVEL"
<> P.value LogInfo
<> P.showDefaultWith (unpack . showLogLevel)
)
-- Bootstraps an application by reading its settings from a provided
-- configuration file. A configuration must exist in the config file for the name
-- provided. A logger object, log level and read-only configuration are passed
-- down to the provided application.
launch :: FromJSON e => String -> (Logger -> LogLevel -> e -> IO a) -> IO a
launch name app =
P.execParser info >>= \(Options path level) ->
returnEnv path >>= \env ->
withoutInputEcho $ withStdOutLogger $ \logger -> app logger level env
where
title :: String
title = "Launch " <> name <> " service"
description :: P.InfoMod Options
description = P.fullDesc <> P.progDesc title
info :: P.ParserInfo Options
info = P.info (parser <**> P.helper) description
err :: String
err = "Service configuration for " <> name <> " not found"
load :: KeyMap Value -> Value
load configs = fromMaybe (error err) $ configs !? fromString name
check :: Result e -> e
check (Success e) = e
check (Error str) = error str
returnEnv :: FromJSON e => String -> IO e
returnEnv = fmap (check . fromJSON . load) . decodeFileThrow
|
