botiut/app/Conf.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}

module Conf
    ( Group(..)
    , Config(..)
    , readConfig
    ) where

import           Control.Monad                  ( mzero )
import qualified Data.HashMap.Strict           as H
import qualified Data.Map.Strict               as Map
import           Data.Maybe                     ( fromMaybe )
import qualified Data.Text                     as T
import           Data.Yaml                      ( (.:)
                                                , FromJSON
                                                , Object
                                                , Parser
                                                , Value(Number, Object, String)
                                                , decodeFileThrow
                                                , parseJSON
                                                , parseMaybe
                                                , withObject
                                                )
import qualified Discord.Types                 as D

import           Data.Either                    ( fromRight )
import           Data.Scientific                ( Scientific
                                                , floatingOrInteger
                                                )
import           Data.Word                      ( Word64 )

data Group = Group
    { groupChannel :: D.Snowflake
    , groupRole    :: D.Snowflake
    , groupAde     :: T.Text
    }
    deriving (Show, Eq, Read)

hmToGroup :: H.HashMap T.Text Value -> Group
hmToGroup hm = Group
    { groupChannel = scitosno
                     . valueNum "channel"
                     . errorRequired "channel"
                     $ H.lookup "channel" hm
    , groupRole = scitosno . valueNum "role" . errorRequired "role" $ H.lookup
                      "role"
                      hm
    , groupAde = valueText "edturl" . errorRequired "edturl" $ H.lookup
                     "edturl"
                     hm
    }

data Config = Config
    { configServer          :: D.Snowflake
    , configGroups          :: Map.Map T.Text Group
    , configAutoEDTCronDay  :: T.Text
    , configAutoEDTCronWeek :: T.Text
    }
    deriving (Show, Eq, Read)

readConfig :: FilePath -> IO Config
readConfig fp = do
    conf_yml <- decodeFileThrow fp :: IO Object
  --  print conf_yml
    return $ ymlToConf conf_yml

ymlToConf :: Object -> Config
ymlToConf v = Config { configServer          = server
                     , configGroups          = groups
                     , configAutoEDTCronDay  = autoEdtCronDay
                     , configAutoEDTCronWeek = autoEdtCronWeek
                     }
  where
    server'      = errorRequired "server" $ H.lookup "server" v
    server       = scitosno $ valueNum "server" server'
    groups       = parseGroups groupsObject
    groupsObject = H.lookup "groups" v
    parseGroups (Just (Object o)) =
        let groupList' :: H.HashMap T.Text Group
            groupList' = fmap
                ( hmToGroup
                . (\case
                      Object u -> u
                      _        -> error "groups are objects"
                  )
                )
                o
        in  Map.fromList $ H.toList groupList'
    parseGroups _ = error "Wrong format for groups"
    autoEdtCronDay =
        valueText "autoEdtCronDay" $ fromMaybe "0 15 * * 0-4" $ H.lookup
            "autoEdtCronDay"
            v
    autoEdtCronWeek =
        valueText "autoEdtCronWeek" $ fromMaybe "30 9 * * 0" $ H.lookup
            "autoEdtCronWeek"
            v


errorRequired :: [Char] -> Maybe a -> a
errorRequired name = fromMaybe (error $ "required field: " ++ name)
valueText :: [Char] -> Value -> T.Text
valueText _    (String t) = t
valueText name _          = error $ name ++ " should be a string"
valueNum :: [Char] -> Value -> Scientific
valueNum _    (Number n) = n
valueNum name _          = error $ name ++ " should be an integer"

scitosno :: Scientific -> D.Snowflake
scitosno =
    D.Snowflake
        . (fromInteger :: Integer -> Word64)
        . fromRight (error "Cant read that as an int")
        . floatingOrInteger