convex-schema-parser-0.1.3.0: app/Config.hs

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}

module Config
  ( loadConfig,
    Config (..),
    TargetConfig (..),
    GenTarget (..),
  )
where

import Data.Aeson
import Data.Char (isAlphaNum)
import Data.List (isPrefixOf)
import Data.Maybe (fromMaybe)
import Data.Traversable (forM)
import Data.Yaml (ParseException, decodeFileEither)
import GHC.Generics (Generic)
import System.Directory (getHomeDirectory)
import System.Environment (getEnv, lookupEnv)
import System.FilePath (joinPath, splitPath, (</>))

data GenTarget = Python | Rust
  deriving (Show, Eq, Enum, Bounded, Generic)

-- Make GenTarget parseable from YAML (as a string)
instance FromJSON GenTarget where
  parseJSON = withText "GenTarget" $ \t ->
    case t of
      "Python" -> pure Python
      "Rust" -> pure Rust
      _ -> fail "Unknown target language. Use 'Python' or 'Rust'."

data TargetConfig = TargetConfig
  { lang :: GenTarget,
    output :: [FilePath]
  }
  deriving (Show, Generic)

instance FromJSON TargetConfig

data ConfigRead = ConfigRead
  { project_path :: FilePath,
    declarations_dir :: FilePath,
    targets :: [TargetConfig],
    validation_path :: Maybe (FilePath)
  }
  deriving (Show, Generic)

instance FromJSON ConfigRead

data Config = Config
  { projectPath :: FilePath,
    declarationsDir :: FilePath,
    targetList :: [TargetConfig],
    validationPath :: FilePath
  }
  deriving (Show, Generic)

-- | Loads and parses the YAML configuration file.
loadConfig :: FilePath -> IO (Either ParseException Config)
loadConfig p = do
  r <- decodeFileEither p
  r' <- case r of
    Right config -> do
      cfg <-
        Config
          <$> (expandFullPath $ project_path config)
          <*> (expandFullPath $ declarations_dir config)
          <*> (mapM expandInTargetConfig (targets config))
          <*> (expandFullPath $ maybe "~/.config/convex-schema-parser" id (validation_path config))
      return $ Right cfg
    Left v -> return (Left v :: Either ParseException Config)
  return r'

expandInTargetConfig :: TargetConfig -> IO TargetConfig
expandInTargetConfig (TargetConfig lang outputs) = do
  expandedOutputs <- mapM expandFullPath outputs
  return $ TargetConfig lang expandedOutputs

expandEnvInPath :: FilePath -> IO FilePath
expandEnvInPath input = do
  let components = splitPath input -- preserves trailing slashes
  expanded <- forM components $ \part ->
    case part of
      ('$' : rest) -> do
        let varName = takeWhile isAlphaNum rest
        mVal <- lookupEnv varName
        return $ fromMaybe part mVal
      _ -> return part
  return $ joinPath expanded

expandUserPath :: FilePath -> IO FilePath
expandUserPath path
  | "~/" `isPrefixOf` path = do
      home <- getHomeDirectory
      return $ home </> drop 2 path
  | "$HOME/" `isPrefixOf` path = do
      home <- getEnv "HOME"
      return $ home </> drop 6 path
  | otherwise = return path

expandFullPath :: FilePath -> IO FilePath
expandFullPath path = do
  expandedEnv <- expandEnvInPath path
  expandedUser <- expandUserPath expandedEnv
  return expandedUser