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
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
|
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeData #-}
{-# LANGUAGE TypeFamilies #-}
module Config (
Config, Config'(..), ConfigStage(..), IfFull,
Channel(..), prettyChannel,
readConfig, enrichConfig,
) where
import Prelude hiding (foldl') -- exported since GHC 9.10 (base 4.20)
import Data.Char (isSpace)
import Data.List (foldl')
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Text (Text)
import Data.Text qualified as T
import Text.Read (readMaybe)
import Util
-- Example config file:
--
-- ```
-- port 8080
-- logs /var/lib/znc/users/ircbrowse/moddata/log
-- channel freenode #haskell fn-haskell
-- channel liberachat #haskell haskell
-- channel liberachat #xmonad xmonad
-- ```
--
-- Lines starting with '#' are ignored.
type Config = Config' Full
-- | Whether a 'Config' is straight from the 'User', or enriched with more
-- information ('Full').
type data ConfigStage = User | Full
data Config' (stage :: ConfigStage) = Config
{ uconfChannels :: IfUser stage (Snoc (Text, Text, Text))
-- ^ (network, channel, alias); channel includes '#'. Alias is used for
-- URLs and must be globally unique.
, confLogsDir :: FilePath
, confPort :: Int
-- ^ Port at which to host the HTTP server
, econfChannels :: IfFull stage [Channel]
-- ^ Network-channel pairs, in user-specified order
, econfChan2Alias :: IfFull stage (Map Channel Text)
-- ^ The URL alias of a network-channel pair
, econfAlias2Chan :: IfFull stage (Map Text Channel)
-- ^ The network-channel pair corresponding to each alias
}
deriving instance Show (Config' User)
deriving instance Show (Config' Full)
type family IfUser stage a where
IfUser User a = a
IfUser Full a = ()
type family IfFull stage a where
IfFull User a = ()
IfFull Full a = a
-- | network, channelname
data Channel = Channel { chanNetwork :: Text, chanChannel :: Text }
deriving (Show, Eq, Ord)
prettyChannel :: Channel -> Text
prettyChannel (Channel nw ch) = nw <> T.pack "/" <> ch
readConfig :: FilePath -> IO (Config' User)
readConfig path = foldl' parseLine initConfig . lines <$> readFile path
enrichConfig :: Config' User -> Config
enrichConfig conf = conf
{ uconfChannels = ()
, econfChannels = [Channel nw ch | (nw, ch, _) <- uchannels]
, econfChan2Alias = Map.fromList [(Channel nw ch, alias) | (nw, ch, alias) <- uchannels]
, econfAlias2Chan = Map.fromList [(alias, Channel nw ch) | (nw, ch, alias) <- uchannels]
}
where
uchannels = toList (uconfChannels conf)
initConfig :: Config' User
initConfig = Config
{ uconfChannels = SnocNil
, confLogsDir = error "config: Log directory not set with 'logs'"
, confPort = 8000
, econfChannels = ()
, econfChan2Alias = ()
, econfAlias2Chan = ()
}
parseLine :: Config' User -> String -> Config' User
parseLine conf line -- skip empty lines and comments
| case dropWhile isSpace line of
[] -> True
'#':_ -> True
_ -> False
= conf
parseLine conf line =
let (cmd, rest) = break (== ' ') line
in case cmd of
"port" ->
case readMaybe (trim rest) of
Just port | 0 <= port, port < 65536 -> conf { confPort = port }
_ -> error "config: Invalid port number"
"logs" ->
let dir = dropWhile isSpace rest
in if null dir
then error "config: Empty 'logs' directory"
else conf { confLogsDir = dropWhile isSpace rest }
"channel" ->
case words (trim rest) of
[network, chan, alias]
| all (not . null) [network, chan, alias]
-> conf { uconfChannels = uconfChannels conf `Snoc` (T.pack network, T.pack chan, T.pack alias) }
_ -> error $ "config: Invalid channel spec: " ++ trim rest
_ -> error $ "config: Invalid line with command '" ++ cmd ++ "'"
where
trim :: String -> String
trim = dropWhile isSpace . reverse . dropWhile isSpace . reverse
|
