{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE RecordWildCards #-}

module Puppy.Config where

import Data.Functor ((<&>), ($>))
import Data.String (IsString)
import Data.Text (Text)
import Effectful
import Effectful.Dispatch.Dynamic (interpret)
import Effectful.Fail (Fail)
import Effectful.NonDet
import Effectful.TH
import Puppy.Crypto.RNG
import Puppy.Crypto.RSA
import Puppy.Files
import Puppy.Logging
import qualified Crypto.PubKey.RSA as RSA
import qualified Data.Aeson.KeyMap as JSON
import qualified Data.Aeson.Types as JSON
import qualified Data.ByteString as BS
import System.Environment (lookupEnv)

version :: IsString s => s
version = "0.1.0"

getLogLevel :: MonadIO m => m Level
getLogLevel = liftIO $ do
  lookupEnv "KAOS_LOG_LEVEL" <&> \case
    Just "debug" -> Debug
    Just "info"  -> Info
    Just "warn"  -> Warn
    _ -> Info

data ServerConfig
  = ServerConfig {
    port      :: Int,
    name      :: Text,
    serverKey :: RSA.PrivateKey,
    logLevel  :: Level
  }

data Config :: Effect where
  GetConfig  :: Config m ServerConfig
  GetsConfig :: (ServerConfig -> a) -> Config m a

makeEffect ''Config

runConfig
  :: ServerConfig
  -> Eff (Config : es) a
  -> Eff es a
runConfig config = interpret $ \_ -> \case
  GetConfig    -> pure config
  GetsConfig f -> pure (f config)

loadConfig 
  :: (Files :> es, RNG :> es, Fail :> es, IOE :> es)
  => Eff es ServerConfig
loadConfig = do
    cfg <- require ".state/config.json" =<< readConfigFile
    logLevel  <- getLogLevel
    -- Attempt to load the key file, and generate a key if one doesn't exist yet.
    serverKey <- loadServerKey
    res <- runNonDet OnEmptyKeep $ do
      port <- require "'port'" 
              (parse cfg "port" <|> pure 1312)
      name <- require "'name'"
              (parse cfg "name")
      pure (ServerConfig { .. })
    either (const (fail "boo")) return res
  where
    parse :: (JSON.FromJSON v) => JSON.Object -> JSON.Key -> Maybe v
    parse obj key = JSON.lookup key obj >>= mayb . JSON.fromJSON
    mayb = \case { JSON.Error _ -> Nothing; JSON.Success a -> Just a }

    require :: (Fail :> xs) => String -> Maybe e -> Eff xs e
    require msg = \case
      Just v -> pure v
      Nothing -> fail ("Requires " <> msg <> " but it is missing")

    loadServerKey = readServerKey >>= \case
      Just key -> case decodePrivateKey (BS.toStrict key) of
        Just k -> return k
        Nothing -> fail "Bad private key!"
      Nothing -> do
        (_, key) <- genRSA
        writeServerKey (BS.fromStrict $ encodePrivateKey key) $> key