{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE OverloadedStrings #-}
module Pansite.Config.Funcs
( readApp
, runTool
) where
import Control.Monad
import Data.Aeson.Types
import qualified Data.ByteString.Char8 as C8
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Traversable
import qualified Data.Vector as Vector
import Data.Yaml
import Pansite.Config.Types
import Pansite.Config.Util
import Pansite.PathPattern
type ToolMap = HashMap String Tool
updateTool :: UpdateContext -> Tool -> Value -> Parser Tool
updateTool ctx (Tool _ u _) value = u ctx value
updateTools :: UpdateContext -> ToolMap -> [(String, Value)] -> Parser ToolMap
updateTools ctx = foldM (\m (key, value) -> case HashMap.lookup key m of
Nothing -> fail $ "Unsupported tool " ++ key
Just toolConfigOrig -> do
toolConfig <- updateTool ctx toolConfigOrig value
return $ HashMap.insert key toolConfig m)
runTool :: RunContext -> Tool -> IO ()
runTool ctx (Tool _ _ r) = r ctx
arrayParser :: Object -> Text -> (Value -> Parser a) -> Parser [a]
arrayParser o key parser = helper (Text.unpack key) parser =<< o .: key
where helper expected f = withArray expected $ \arr -> mapM f (Vector.toList arr)
appParser :: UpdateContext -> [Tool] -> Value -> Parser App
appParser ctx tools = withObject "App" $ \o -> do
let toolMapOrig = HashMap.fromList (map (\t@(Tool k _ _) -> (k, t)) tools)
toolSettings <- toolSettingsParser =<< o .:? "tool-settings" .!= emptyObject
toolMapNew <- updateTools ctx toolMapOrig toolSettings
routes <- arrayParser o "routes" (routeParser ctx)
targets <- arrayParser o "targets" (targetParser ctx toolMapNew)
return $ App routes targets
toolSettingsParser :: Value -> Parser [(String, Value)]
toolSettingsParser = withObject "tool-settings" $ \o ->
for (HashMap.toList o) $ \(name, value) -> return (Text.unpack name, value)
routeParser :: UpdateContext -> Value -> Parser Route
routeParser (UpdateContext resolveFilePath) =
withObject "route" $ \o -> Route
<$> splitRoutePath <$> o .: "path"
<*> (resolveFilePath <$> o .: "target")
pathPatternParser :: FilePathResolver -> String -> Parser PathPattern
pathPatternParser resolveFilePath s = case pathPattern (resolveFilePath s) of
Left message -> fail message
Right p -> return p
targetParser :: UpdateContext -> ToolMap -> Value -> Parser Target
targetParser ctx@(UpdateContext resolveFilePath) toolMap =
withObject "target" $ \o -> do
let pathPatternParser' = pathPatternParser resolveFilePath
path <- pathPatternParser' =<< o .: "path"
key <- o .: "tool"
toolConfigOrig <- case HashMap.lookup key toolMap of
Nothing -> fail $ "Unsupported tool " ++ key
Just p -> return p
toolConfig <- updateTool ctx toolConfigOrig =<< o .:? "tool-settings" .!= emptyObject
inputPaths <- mapM pathPatternParser' =<< o .: "inputs"
dependencyPaths <- mapM pathPatternParser' =<< o .: "dependencies"
return $ Target path toolConfig inputPaths dependencyPaths
parseExceptionMessage :: FilePath -> ParseException -> String
parseExceptionMessage appYamlPath (InvalidYaml (Just (YamlException problem))) =
"Invalid YAML: " ++ problem ++ "\n" ++
"Location: " ++ appYamlPath
parseExceptionMessage appYamlPath (InvalidYaml (Just (YamlParseException problem ctx (YamlMark _ line column)))) =
"Invalid YAML: " ++ problem ++ " " ++ ctx ++ "\n" ++
"Location: " ++ appYamlPath ++ ":" ++ show line ++ ":" ++ show column
parseExceptionMessage appYamlPath (InvalidYaml _) = "Invalid YAML in " ++ appYamlPath
parseExceptionMessage _ e = error $ "Unhandled exception: " ++ show e
resultErrorMessage :: FilePath -> String -> String
resultErrorMessage appYamlPath problem =
"Invalid configuration: " ++ problem ++ "\n" ++
"Location: " ++ appYamlPath
readApp :: UpdateContext -> [Tool] -> FilePath -> IO (Either String App)
readApp ctx tools appYamlPath = do
yaml <- C8.readFile appYamlPath
case decodeEither' yaml of
Left e -> do
putStrLn $ "WARNING: " ++ parseExceptionMessage appYamlPath e
return $ Left (show e)
Right value -> do
case parse (appParser ctx tools) value of
Error problem -> do
putStrLn $ "WARNING: " ++ resultErrorMessage appYamlPath problem
return $ Left problem
Success app@(App routes targets) -> do
forM_ routes $ \(Route path target) ->
putStrLn $ "Route: " ++ show path ++ " -> " ++ target
forM_ targets $ \(Target path _ inputPaths dependencyPaths) -> do
putStrLn $ "Target: " ++ show path ++ ", " ++ show inputPaths ++ ", " ++ show dependencyPaths
return $ Right app