1 files changed, 125 insertions, 0 deletions
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