botiut/app/Conf.hs

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

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

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

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

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