module Compiler where import Codec.Compression.GZip (bestCompression, compressLevel, compressWith, decompress, defaultCompressParams) import Data.Aeson (eitherDecode) import Data.Aeson.Encode.Pretty (encodePretty) import Data.Binary (decodeOrFail, encode) import qualified Data.ByteString.Lazy.Char8 as BS import Data.List (find, stripPrefix) import System.Directory (getCurrentDirectory, getHomeDirectory) import System.FilePath (normalise, takeDirectory, ()) import qualified Parser as P import Types import Utils compileRef :: [Card] -> Maybe CardNameReference -> Sparker [Deployment] compileRef cs mcnr = do firstCard <- case mcnr of Nothing -> if null cs then throwError $ CompileError "No cards found for compilation." else return $ head cs Just (CardNameReference name) -> do case find (\c -> card_name c == name) cs of Nothing -> throwError $ CompileError $ unwords ["Card", name, "not found for compilation."] Just card -> return card compile firstCard cs compile :: Card -> [Card] -> Sparker [Deployment] compile card allCards = do initial <- initialState card allCards ((_,_),dps) <- runSparkCompiler initial compileDeployments return dps outputCompiled :: [Deployment] -> Sparker () outputCompiled deps = do form <- asks conf_compile_format out <- asks conf_compile_output case form of FormatBinary -> do case out of Nothing -> liftIO $ BS.putStrLn $ compressWith compressionParams $ encode deps Just fp -> liftIO $ BS.writeFile fp $ compressWith compressionParams $ encode deps FormatText -> do let str = unlines $ map show deps case out of Nothing -> liftIO $ putStrLn str Just fp -> liftIO $ writeFile fp str FormatJson -> do let bs = encodePretty deps case out of Nothing -> liftIO $ BS.putStrLn bs Just fp -> liftIO $ BS.writeFile fp bs FormatStandalone -> notImplementedYet where compressionParams = defaultCompressParams {compressLevel = bestCompression} inputCompiled :: FilePath -> Sparker [Deployment] inputCompiled fp = do form <- asks conf_compile_format case form of FormatBinary -> do content <- liftIO $ BS.readFile fp case decodeOrFail $ decompress content of Left (_,_,err) -> throwError $ CompileError $ "Something went wrong while deserialising binary data: " ++ err Right (_,_,deps) -> return deps FormatText -> do str <- liftIO $ readFile fp return $ map read $ lines str FormatJson -> do bs <- liftIO $ BS.readFile fp case eitherDecode bs of Left err -> throwError $ CompileError $ "Something went wrong while deserialising json data: " ++ err Right ds -> return ds FormatStandalone -> throwError $ CompileError "You're not supposed to use standalone compiled deployments in any other way than by executing it." initialState :: Card -> [Card] -> Sparker CompilerState initialState c@(Card _ fp statement) cds = do currentDir <- liftIO getCurrentDirectory override <- asks conf_compile_kind return $ CompilerState { state_current_card = c , state_current_directory = currentDir takeDirectory fp , state_all_cards = cds , state_declarations_left = [statement] , state_deployment_kind_override = override , state_into = "" , state_outof_prefix = [] } -- Compiler pop :: SparkCompiler Declaration pop = do dec <- gets state_declarations_left modify (\s -> s {state_declarations_left = tail dec}) return $ head dec done :: SparkCompiler Bool done = fmap null $ gets state_declarations_left compileDeployments :: SparkCompiler () compileDeployments = do d <- done if d then return () else processDeclaration >> compileDeployments add :: Deployment -> SparkCompiler () add dep = tell [dep] addAll :: [Deployment] -> SparkCompiler () addAll = tell resolvePrefix :: CompilerPrefix -> [FilePath] resolvePrefix [] = [] resolvePrefix [Literal s] = [s] resolvePrefix [Alts ds] = ds resolvePrefix ((Literal s):ps) = do rest <- resolvePrefix ps return $ s rest resolvePrefix ((Alts as):ps) = do a <- as rest <- resolvePrefix ps return $ a rest sources :: FilePath -> PrefixPart sources fp@('.':f) = Alts [fp, f] sources fp = Literal fp stripHome :: FilePath -> SparkCompiler FilePath stripHome fp = do home <- liftIO $ getHomeDirectory return $ case home `stripPrefix` fp of Nothing -> fp Just stripped -> "~" ++ stripped processDeclaration :: SparkCompiler () processDeclaration = do dec <- pop case dec of Deploy src dst kind -> do override <- gets state_deployment_kind_override superOverride <- asks conf_compile_override let resultKind = case (superOverride, override, kind) of (Nothing, Nothing, Nothing) -> LinkDeployment (Nothing, Nothing, Just k ) -> k (Nothing, Just o , _ ) -> o (Just o , _ , _ ) -> o dir <- gets state_current_directory outof <- gets state_outof_prefix into <- gets state_into let alts = map normalise . resolvePrefix $ [Literal dir] ++ outof ++ [sources src] let dest = normalise $ into dst alternates <- mapM stripHome alts destination <- stripHome dest add $ Put alternates destination resultKind SparkOff st -> do case st of CardFile (CardFileReference file mn) -> do dir <- gets state_current_directory newCards <- liftSparker $ P.parseFile $ dir file oldCards <- gets state_all_cards let allCards = oldCards ++ newCards nextCard <- case mn of Nothing -> return $ head newCards Just (CardNameReference name) -> case find (\c -> card_name c == name) allCards of Nothing -> throwError $ CompileError "card not found" -- FIXME this is unsafe. Just c -> return c newDeclarations <- liftSparker $ compile nextCard newCards modify (\s -> s {state_all_cards = allCards}) addAll newDeclarations CardName (CardNameReference name) -> do allCards <- gets state_all_cards case find (\c -> card_name c == name) allCards of Nothing -> throwError $ CompileError "card not found" -- FIXME this is unsafe. Just c@(Card _ _ statement) -> do before <- get modify (\s -> s {state_declarations_left = [statement] ,state_current_card = c}) compileDeployments put before IntoDir dir -> do ip <- gets state_into if null ip then modify (\s -> s {state_into = dir} ) else modify (\s -> s {state_into = ip dir} ) OutofDir dir -> do op <- gets state_outof_prefix modify (\s -> s {state_outof_prefix = op ++ [Literal dir]}) DeployKindOverride kind -> modify (\s -> s {state_deployment_kind_override = Just kind }) Block ds -> do before <- get modify (\s -> s {state_declarations_left = ds}) compileDeployments put before Alternatives ds -> do op <- gets state_outof_prefix modify (\s -> s {state_outof_prefix = op ++ [Alts ds]}) liftSparker :: Sparker a -> SparkCompiler a liftSparker = lift . lift