blob: 1bb34654a1375a6fb446e8fc25899302f27197f1 (
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
76
77
78
79
80
81
82
83
84
85
86
87
88
|
{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE ImportQualifiedPost #-}
module Hsm.Core.App
( launch
, launchWithEcho
)
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.Composition ((.:))
import Data.Function.Slip (slipl)
import Data.Maybe (fromMaybe)
import Data.Text (pack, unpack)
import Data.Yaml (decodeFileThrow)
import Effectful.Log qualified as L
import Log.Backend.StandardOutput (withStdOutLogger)
import Options.Applicative qualified as P
import System.IO.Echo (withoutInputEcho)
data Options = Options String L.LogLevel
type App e a = e -> L.Logger -> L.LogLevel -> IO a
parser :: P.Parser Options
parser = do
config <-
P.strOption $
P.help "Path to services config file"
<> P.short 'c'
<> P.long "config"
<> P.metavar "PATH"
<> P.value "config.yaml"
<> P.showDefault
level <-
P.option (P.eitherReader $ L.readLogLevelEither . pack) $
P.help "Log level"
<> P.short 'l'
<> P.long "log-level"
<> P.metavar "LEVEL"
<> P.value L.LogInfo
<> P.showDefaultWith (unpack . L.showLogLevel)
pure $ Options config level
launchWith
:: forall e a
. FromJSON e
=> String
-> App e a
-> (IO a -> IO a)
-> IO a
launchWith name app wrapper = do
Options path level <- P.execParser info
returnEnv path >>= runApp level
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 :: String -> IO e
returnEnv = fmap (check . fromJSON . load) . decodeFileThrow
runApp :: L.LogLevel -> e -> IO a
runApp = wrapper . withStdOutLogger .: slipl app
launch :: FromJSON e => String -> App e a -> IO a
launch = slipl launchWith withoutInputEcho
launchWithEcho :: FromJSON e => String -> App e a -> IO a
launchWithEcho = slipl launchWith id
|
