From f21dcde54b09913550036e6501cca935278597d9 Mon Sep 17 00:00:00 2001 From: Tom Smeding Date: Sun, 29 Mar 2026 23:25:10 +0200 Subject: Initial --- src/Config.hs | 125 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 125 insertions(+) create mode 100644 src/Config.hs (limited to 'src/Config.hs') diff --git a/src/Config.hs b/src/Config.hs new file mode 100644 index 0000000..7fe9e6a --- /dev/null +++ b/src/Config.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeData #-} +{-# LANGUAGE TypeFamilies #-} +module Config ( + Config, Config'(..), ConfigStage(..), IfFull, + Channel(..), + readConfig, enrichConfig, +) where + +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) + +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 -- cgit v1.3