diff --git a/src/Arguments.hs b/src/Arguments.hs new file mode 100644 --- /dev/null +++ b/src/Arguments.hs @@ -0,0 +1,191 @@ +module Arguments where + +import Data.Monoid (mconcat) +import Options.Applicative +import System.Environment (getArgs) + +import Types +import Utils + + +getInstructions :: IO Instructions +getInstructions = do + mins <- fmap transformOptions getOptions + case mins of + Right ins -> return ins + Left err -> die $ "Failed to parse instructions\n" ++ err + +transformOptions :: Options -> Either String Instructions +transformOptions (dispatch, go) = (,) <$> pure dispatch <*> configFromOptions go + +configFromOptions :: GlobalOptions -> Either String SparkConfig +configFromOptions go = Right conf + where + conf = Config { + conf_format_lineUp = if opt_compress go then False else opt_lineUp go + , conf_format_indent = if opt_compress go then 0 else opt_indent go + , conf_format_trailingNewline = if opt_compress go then False else opt_trailingNewline go + , conf_format_alwaysQuote = if opt_compress go then False else opt_alwaysQuote go + , conf_format_oneLine = opt_compress go + , conf_compile_output = opt_output go + , conf_compile_format = opt_format go + , conf_compile_kind = opt_kind go + , conf_compile_override = opt_overrride go + , conf_check_thoroughness = opt_thoroughness go + , conf_deploy_replace_links = opt_replace_links go || opt_replace go + , conf_deploy_replace_files = opt_replace_files go || opt_replace go + , conf_deploy_replace_directories = opt_replace_directories go || opt_replace go + , conf_debug = opt_debug go + } + +getOptions :: IO Options +getOptions = do + args <- getArgs + let result = runOptionsParser args + handleParseResult result + +runOptionsParser :: [String] -> ParserResult Options +runOptionsParser strs = execParserPure prefs optionsParser strs + where prefs = ParserPrefs { + prefMultiSuffix = "SPARK" -- ^ metavar suffix for multiple options + , prefDisambiguate = True -- ^ automatically disambiguate abbreviations (default: False) + , prefShowHelpOnError = True -- ^ always show help text on parse errors (default: False) + , prefBacktrack = True -- ^ backtrack to parent parser when a subcommand fails (default: True) + , prefColumns = 80 -- ^ number of columns in the terminal, used to format the help page (default: 80) + } + +optionsParser :: ParserInfo Options +optionsParser = info (helper <*> parseOptions) help + where + help = fullDesc <> progDesc description + description = "Super User Spark, author: Tom Sydney Kerckhove" + +parseOptions :: Parser Options +parseOptions = (,) <$> parseCommand <*> parseGlobalOptions + +parseCommand :: Parser Dispatch +parseCommand = hsubparser $ mconcat + [ + command "parse" parseParse + , command "format" parseFormat + , command "compile" parseCompile + , command "check" parseCheck + , command "deploy" parseDeploy + ] + +parseParse :: ParserInfo Dispatch +parseParse = info parser modifier + where + parser = DispatchParse <$> strArgument (metavar "FILE" <> help "the file to parse") + modifier = fullDesc + <> progDesc "Parse a spark file and check for syntactic errors." + +parseFormat :: ParserInfo Dispatch +parseFormat = info parser modifier + where + parser = DispatchFormat <$> strArgument (metavar "FILE" <> help "the file to format") + modifier = fullDesc + <> progDesc "Format a spark file." + +parseCompile :: ParserInfo Dispatch +parseCompile = info parser modifier + where + parser = DispatchCompile + <$> argument auto + (metavar "CARD" <> help "the card file to compile") + modifier = fullDesc + <> progDesc "Compile a spark card." + +parseCheck :: ParserInfo Dispatch +parseCheck = info parser modifier + where + parser = DispatchCheck + <$> argument auto + (metavar "CARD" <> help "the card to check") + modifier = fullDesc + <> progDesc "Check the deployment of a spark card." + +parseDeploy :: ParserInfo Dispatch +parseDeploy = info parser modifier + where + parser = DispatchDeploy + <$> argument auto + (metavar "CARD" <> help "the card to deploy") -- TODO more help + modifier = fullDesc + <> progDesc "Deploy a spark card." + + +parseGlobalOptions :: Parser GlobalOptions +parseGlobalOptions = GlobalOptions + <$> flag True False -- Backwards + ( long "no-line-up" + <> short 'L' + <> help "Don't line up arrows" ) + <*> option auto + ( long "indent" + <> short 'i' + <> value 4 + <> metavar "NUM" + <> help "How many spaces to use for indentation when formatting" ) + <*> flag True False -- Backwards + ( long "no-trailing-newline" + <> short 'N' + <> help "Don't add a trailing newline to a formatted file" ) + <*> switch + ( long "always-quote" + <> short 'Q' + <> help "Always quote file names" ) + <*> switch + ( long "compress" + <> short 'c' + <> help "Compress the card as much as possible." ) + <*> option (Just <$> str) + ( long "output" + <> short 'o' + <> value Nothing + <> metavar "FILE" + <> help "The output file for compilation" ) + <*> option auto + ( long "format" + <> short 'f' + <> value FormatText + <> metavar "FORMAT" + <> help "Compilation format" ) + <*> option (Just <$> auto) + ( long "kind" + <> short 'k' + <> value Nothing + <> metavar "KIND" + <> help "The kind specification for unspecified deployments (default: link)" ) + <*> option (Just <$> auto) + ( long "override" + <> short 'O' + <> value Nothing + <> metavar "KIND" + <> help "Override every deployment to be of the given kind" ) + <*> option auto + ( long "thoroughness" + <> short 't' + <> value ThoroughnessContent + <> metavar "THOROUGHNESS" + <> help "How thoroughly to check whether the source and destination are equal" ) + <*> switch + ( long "replace-links" + <> help "Replace links at deploy destinations." + ) + <*> switch + ( long "replace-files" + <> help "Replace existing files at deploy destinations." + ) + <*> switch + ( long "replace-Directories" + <> help "Replace existing directories at deploy destinations." + ) + <*> switch + ( long "replace" + <> short 'r' + <> help "Equivalent to --replace-files --replace-directories --replace-links" + ) + <*> switch + ( long "debug" + <> help "Show al debug information." ) diff --git a/src/Compiler.hs b/src/Compiler.hs new file mode 100644 --- /dev/null +++ b/src/Compiler.hs @@ -0,0 +1,219 @@ +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 diff --git a/src/Constants.hs b/src/Constants.hs new file mode 100644 --- /dev/null +++ b/src/Constants.hs @@ -0,0 +1,70 @@ +module Constants where + +keywordCard :: String +keywordCard = "card" + +keywordSpark :: String +keywordSpark = "spark" + +keywordGit :: String +keywordGit = "git" + +keywordFile :: String +keywordFile = "file" + +keywordInto :: String +keywordInto = "into" + +keywordOutof :: String +keywordOutof = "outof" + +keywordKindOverride :: String +keywordKindOverride = "kind" + +keywordLink :: String +keywordLink = "link" + +keywordCopy :: String +keywordCopy = "copy" + +keywordAlternatives :: String +keywordAlternatives = "alternatives" + +linkKindSymbol :: String +linkKindSymbol = "l->" + +copyKindSymbol :: String +copyKindSymbol = "c->" + +unspecifiedKindSymbol :: String +unspecifiedKindSymbol = "->" + +bracesChars :: [Char] +bracesChars = ['{','}'] + +linespaceChars :: [Char] +linespaceChars = [' ', '\t'] + +endOfLineChars :: [Char] +endOfLineChars = ['\n','\r'] + +whitespaceChars :: [Char] +whitespaceChars = linespaceChars ++ endOfLineChars + +lineDelimiter :: String +lineDelimiter = ";" + +branchDelimiter :: String +branchDelimiter = ":" + +quotesChar :: Char +quotesChar = '"' + +lineCommentStr :: String +lineCommentStr = "#" + +blockCommentStrs :: (String, String) +blockCommentStrs = ("[[", "]]") + +sparkExtension :: String +sparkExtension = "sus" diff --git a/src/Deployer.hs b/src/Deployer.hs new file mode 100644 --- /dev/null +++ b/src/Deployer.hs @@ -0,0 +1,357 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Deployer where + +import Data.List (isPrefixOf) +import Data.Maybe (catMaybes) +import Data.Text (pack) +import Prelude hiding (error) +import Shelly (cp_r, fromText, shelly) +import System.Directory (createDirectoryIfMissing, emptyPermissions, + getDirectoryContents, getHomeDirectory, + getPermissions, removeDirectoryRecursive, + removeFile) +import System.Posix.Env (getEnv) + +import System.Exit (ExitCode (..)) +import System.FilePath (dropFileName, normalise, ()) +import System.Posix.Files (createSymbolicLink, fileExist, + getSymbolicLinkStatus, isBlockDevice, + isCharacterDevice, isDirectory, + isNamedPipe, isRegularFile, isSocket, + isSymbolicLink, readSymbolicLink) +import System.Process (system) + +import Formatter (formatPostDeployments, + formatPreDeployments) +import Types +import Utils + + +deploy :: [Deployment] -> Sparker () +deploy dps = do + state <- initialState dps + _ <- runSparkDeployer state $ deployAll dps + return () + +check :: [Deployment] -> Sparker [PreDeployment] +check dps = do + state <- initialState dps + (pdps, _) <- runSparkDeployer state $ predeployments dps + return pdps + + +initialState :: [Deployment] -> Sparker DeployerState +initialState _ = return DeployerState + +deployAll :: [Deployment] -> SparkDeployer () +deployAll deps = do + pdps <- predeployments deps + + case catErrors pdps of + [] -> do + deployments pdps + postdeployments deps pdps + + ss -> throwError $ DeployError $ PreDeployError ss + +catErrors :: [PreDeployment] -> [String] +catErrors [] = [] +catErrors (s:ss) = case s of + Ready _ _ _ -> catErrors ss + AlreadyDone -> catErrors ss + Error str -> str : catErrors ss + + +predeployments :: [Deployment] -> SparkDeployer [PreDeployment] +predeployments dps = do + pdps <- mapM preDeployment dps + lift $ debug $ formatPreDeployments $ zip dps pdps + return pdps + + +preDeployment :: Deployment -> SparkDeployer PreDeployment +preDeployment (Put [] dst _) = return $ Error $ unwords ["No source for deployment with destination:", dst] +preDeployment dep@(Put (src:ss) dst kind) = do + s <- complete src + d <- complete dst + sd <- diagnose s + dd <- diagnose d + + let ready = return (Ready s d kind) :: SparkDeployer PreDeployment + + case (sd, dd, kind) of + (NonExistent , _ , _ ) -> preDeployment (Put ss d kind) + (IsFile _ , NonExistent , _ ) -> ready + (IsFile _ , IsFile _ , LinkDeployment) -> incaseElse conf_deploy_replace_files + (rmFile d >> preDeployment dep) + (error ["Destination", d, "already exists and is file (for a link deployment):", s, "."]) + (IsFile _ , IsFile _ , CopyDeployment) -> do + equal <- compareFiles s d + if equal + then done + else do + incaseElse conf_deploy_replace_files + (rmFile d >> preDeployment dep) + (error ["Destination", d, "already exists and is a file, different from the source:", s, "."]) + (IsFile _ , IsDirectory _ , _ ) -> incaseElse conf_deploy_replace_directories + (rmDir d >> preDeployment dep) + (error ["Destination", d, "already exists and is a directory."]) + (IsFile _ , IsLink _ , LinkDeployment) -> do + point <- liftIO $ readSymbolicLink d + if point `filePathEqual` s + then done + else do + liftIO $ putStrLn $ point ++ " is not equal to " ++ d + incaseElse conf_deploy_replace_links + (unlink d >> preDeployment dep) + (error ["Destination", d, "already exists and is a symbolic link but not to the source."]) + (IsFile _ , IsLink _ , CopyDeployment) -> incaseElse conf_deploy_replace_links + (unlink d >> preDeployment dep) + (error ["Destination", d, "already exists and is a symbolic link (for a copy deployment):", s, "."]) + (IsFile _ , _ , _ ) -> error ["Destination", d, "already exists and is something weird."] + (IsDirectory _ , NonExistent , _ ) -> ready + (IsDirectory _ , IsFile _ , _ ) -> incaseElse conf_deploy_replace_files + (rmFile d >> preDeployment dep) + (error ["Destination", d, "already exists and is a file."]) + (IsDirectory _ , IsDirectory _ , LinkDeployment) -> incaseElse conf_deploy_replace_directories + (rmDir d >> preDeployment dep) + (error ["Destination", d, "already exists and is directory (for a link deployment):", s, "."]) + (IsDirectory _ , IsDirectory _ , CopyDeployment) -> do + equal <- compareDirectories s d + if equal + then done + else do + incaseElse conf_deploy_replace_directories + (rmDir d >> preDeployment dep) + (error ["Destination", d, "already exists and is a directory, different from the source."]) + (IsDirectory _ , IsLink _ , LinkDeployment) -> do + point <- liftIO $ readSymbolicLink d + if point `filePathEqual` s + then done + else incaseElse conf_deploy_replace_links + (unlink d >> preDeployment dep) + (error ["Destination", d, "already exists and is a symbolic link but not to the source."]) + (IsDirectory _ , IsLink _ , CopyDeployment) -> incaseElse conf_deploy_replace_links + (unlink d >> preDeployment dep) + (error ["Destination", d, "already exists and is a symbolic link."]) + (IsLink _ , _ , _ ) -> error ["Source", s, "is a symbolic link."] + _ -> error ["Source", s, "is not a valid file type."] + + + where + done :: SparkDeployer PreDeployment + done = return $ AlreadyDone + + + error :: [String] -> SparkDeployer PreDeployment + error strs = return $ Error $ unwords strs + + +cmpare :: FilePath -> FilePath -> SparkDeployer Bool +cmpare f1 f2 = do + d1 <- diagnose f1 + d2 <- diagnose f2 + if d1 /= d2 + then return False + else case d1 of + IsFile _ -> compareFiles f1 f2 + IsDirectory _ -> compareDirectories f1 f2 + _ -> return True + +compareFiles :: FilePath -> FilePath -> SparkDeployer Bool +compareFiles f1 f2 = do + s1 <- liftIO $ readFile f1 + s2 <- liftIO $ readFile f2 + return $ s1 == s2 + +compareDirectories :: FilePath -> FilePath -> SparkDeployer Bool +compareDirectories d1 d2 = do + dc1 <- contents d1 + dc2 <- contents d2 + b <- mapM (uncurry cmpare) $ zip dc1 dc2 + return $ and b + where + contents d = do + cs <- liftIO $ getDirectoryContents d + return $ filter (\f -> not $ f == "." || f == "..") cs + +diagnose :: FilePath -> SparkDeployer Diagnostics +diagnose fp = do + e <- liftIO $ fileExist fp + if e + then do + s <- liftIO $ getSymbolicLinkStatus fp + if isBlockDevice s + then return IsBlockDevice + else if isCharacterDevice s + then return IsCharDevice + else if isSocket s + then return IsSocket + else if isNamedPipe s + then return IsPipe + else do + p <- liftIO $ getPermissions fp + if isSymbolicLink s + then return $ IsLink p + else if isDirectory s + then return $ IsDirectory p + else if isRegularFile s + then return $ IsFile p + else throwError $ UnpredictedError "Contact the author if you see this" + else do + -- Because if a link exists, but it points to something that doesn't exist, it is considered as non-existent by `fileExist` + es <- liftIO $ system $ unwords ["test", "-L", fp] + case es of + ExitSuccess -> return $ IsLink emptyPermissions + ExitFailure _ -> return NonExistent + + + +deployments :: [PreDeployment] -> SparkDeployer [Maybe String] +deployments = mapM deployment + +deployment :: PreDeployment -> SparkDeployer (Maybe String) +deployment AlreadyDone = return Nothing +deployment (Error str) = return $ Just str +deployment (Ready src dst kind) = do + case kind of + LinkDeployment -> link src dst + CopyDeployment -> copy src dst + return Nothing + +copy :: FilePath -> FilePath -> SparkDeployer () +copy src dst = do + debug $ unwords ["Copying:", src, "c->", dst] + liftIO $ createDirectoryIfMissing True upperDir + liftIO $ shelly $ cp_r (fromText $ pack src) (fromText $ pack dst) + where upperDir = dropFileName dst + +link :: FilePath -> FilePath -> SparkDeployer () +link src dst = do + debug $ unwords ["Linking:", src, "l->", dst] + liftIO $ createDirectoryIfMissing True upperDir + liftIO $ createSymbolicLink src dst + where upperDir = dropFileName dst + + +-- TODO these dont catch errors +unlink :: FilePath -> SparkDeployer () +unlink fp = do + es <- liftIO $ system $ unwords $ ["/usr/bin/unlink", fp] + case es of + ExitSuccess -> debug $ unwords ["unlinked", fp] + ExitFailure _ -> throwError $ DeployError $ PreDeployError ["Something went wrong while unlinking " ++ fp ++ "."] + +rmFile :: FilePath -> SparkDeployer () +rmFile fp = do + liftIO $ removeFile fp + debug $ unwords ["removed", fp] + +rmDir :: FilePath -> SparkDeployer () +rmDir fp = do + liftIO $ removeDirectoryRecursive fp + debug $ unwords ["removed", fp] + + +postdeployments :: [Deployment] -> [PreDeployment] -> SparkDeployer () +postdeployments deps predeps = do + pdps <- mapM postdeployment predeps + lift $ debug $ formatPostDeployments $ zip deps pdps + case catMaybes pdps of + [] -> return () + es -> throwError $ DeployError $ PostDeployError es + +postdeployment :: PreDeployment -> SparkDeployer (Maybe String) +postdeployment AlreadyDone = return Nothing +postdeployment (Error _) = throwError $ UnpredictedError "Contact the author if you see this. (postdeployment)" +postdeployment (Ready src dst kind) = do + sd <- diagnose src + dd <- diagnose dst + + case (sd, dd, kind) of + (NonExistent , _ , _ ) -> error ["The source", src, "is somehow missing after deployment."] + (IsFile _ , NonExistent , _ ) -> error ["The destination", dst, "is somehow non-existent after deployment."] + (IsFile _ , IsFile _ , LinkDeployment) -> error ["The destination", dst, "is somehow a file while it was a link deployment."] + (IsFile _ , IsFile _ , CopyDeployment) -> compareFile + (IsFile _ , IsDirectory _ , _ ) -> error ["The destination", dst, "is somehow a directory after the deployment of the file", src, "."] + (IsFile _ , IsLink _ , LinkDeployment) -> compareLink + (IsFile _ , IsLink _ , CopyDeployment) -> error ["The destination", dst, "is somehow a link while it was a copy deployment."] + (IsFile _ , _ , _ ) -> error ["The destination", dst, "is something weird after deployment."] + (IsDirectory _ , NonExistent , _ ) -> error ["The destination", dst, "is somehow non-existent after deployment."] + (IsDirectory _ , IsFile _ , _ ) -> error ["The destination", dst, "is somehow a file after the deployment of the directory", src, "."] + (IsDirectory _ , IsDirectory _ , LinkDeployment) -> error ["The destination", dst, "is somehow a directory while it was a link deployment."] + (IsDirectory _ , IsDirectory _ , CopyDeployment) -> compareDir + (IsDirectory _ , IsLink _ , LinkDeployment) -> compareLink + (IsDirectory _ , IsLink _ , CopyDeployment) -> error ["The destination", dst, "is somehow a link while it was a copy deployment."] + (IsDirectory _ , _ , _ ) -> error ["The destination", dst, "is something weird after deployment."] + (IsLink _ , _ , _ ) -> error ["The source", src, "is a symbolic link."] + _ -> error ["The source", src, "is something weird."] + + where + fine :: SparkDeployer (Maybe String) + fine = return Nothing + + error :: [String] -> SparkDeployer (Maybe String) + error err = return $ Just $ unwords err + + compareFile :: SparkDeployer (Maybe String) + compareFile = do + equal <- compareFiles src dst + if equal + then fine + else error ["The source and destination files are somehow still not equal."] + + compareDir :: SparkDeployer (Maybe String) + compareDir = do + equal <- compareDirectories src dst + if equal + then fine + else error ["The source and destination directories are somehow still not equal."] + + compareLink :: SparkDeployer (Maybe String) + compareLink = do + point <- liftIO $ readSymbolicLink dst + if point `filePathEqual` src + then fine + else do + debug $ unwords ["The destination points to", point, "but the src points to", src] + error ["The destination is a symbolic link, but it doesn't point to the source."] + +filePathEqual :: FilePath -> FilePath -> Bool +filePathEqual f g = (normalise f) == (normalise g) + +complete :: FilePath -> SparkDeployer FilePath +complete fp = liftIO $ completeI fp + +completeI :: FilePath -> IO FilePath +completeI fp = do + let ids = parseId fp + strs <- mapM replaceId ids + completed <- mapM replaceHome strs + return $ concat completed + +parseId :: FilePath -> [ID] +parseId [] = [Plain ""] +parseId ('$':'(':rest) = (Var id):(parseId next) + where (id, (')':next)) = break (\c -> c == ')') rest +parseId (s:ss) = case parseId ss of + (Plain str):r -> (Plain (s:str)):r + r -> (Plain [s]):r + + +replaceId :: ID -> IO FilePath +replaceId (Plain str) = return str +replaceId (Var str) = do + e <- getEnv str + return $ case e of + Nothing -> "" + Just fp -> fp + +replaceHome :: FilePath -> IO FilePath +replaceHome path = do + home <- getHomeDirectory + return $ if "~" `isPrefixOf` path + then home drop 2 path + else path + diff --git a/src/Dispatch.hs b/src/Dispatch.hs new file mode 100644 --- /dev/null +++ b/src/Dispatch.hs @@ -0,0 +1,33 @@ +module Dispatch where + +import Compiler +import Deployer +import Formatter +import Parser +import Types + +dispatch :: Dispatch -> Sparker () +dispatch (DispatchParse fp) = parseFile fp >> return () -- Just parse, throw away the results. +dispatch (DispatchFormat fp) = do + cards <- parseFile fp + str <- formatCards cards + liftIO $ putStrLn str +dispatch (DispatchCompile (CardFileReference fp mcnr)) = do + cards <- parseFile fp + deployments <- compileRef cards mcnr + outputCompiled deployments +dispatch (DispatchCheck ccr) = do + deps <- case ccr of + DeployerCardCompiled fp -> inputCompiled fp + DeployerCardUncompiled (CardFileReference fp mcnr) -> do + cards <- parseFile fp + compileRef cards mcnr + pdps <- check deps + liftIO $ putStr $ formatPreDeployments $ zip deps pdps +dispatch (DispatchDeploy dcr) = do + deps <- case dcr of + DeployerCardCompiled fp -> inputCompiled fp + DeployerCardUncompiled scr -> do + cards <- parseCardFileReference scr + compile (head cards) cards -- filtering is already done at parse + deploy deps diff --git a/src/Formatter.hs b/src/Formatter.hs new file mode 100644 --- /dev/null +++ b/src/Formatter.hs @@ -0,0 +1,283 @@ +module Formatter where + +import Data.List (intersperse) +import Data.Maybe (catMaybes) + +import Constants +import Types + +formatCards :: [Card] -> Sparker String +formatCards cs = do + initial <- initialState + (_, res) <- runSparkFormatter initial (cards cs) + return res + +initialState :: Sparker FormatterState +initialState = return $ FormatterState { + state_current_indent = 0 + , state_longest_src = 0 + , state_newline_before_deploy = True + } + + +cards :: [Card] -> SparkFormatter () +cards cs = onLines card cs + +delimited :: (a -> SparkFormatter ()) -> [a] -> SparkFormatter () +delimited thingFormatter things = do + let allThings = map thingFormatter things + sequence_ $ intersperse delimiter allThings + +onLines :: (a -> SparkFormatter ()) -> [a] -> SparkFormatter () +onLines thingFormatter things = do + let allThings = map thingFormatter things + sequence_ $ intersperse newline allThings + + +card :: Card -> SparkFormatter () +card (Card name _ d) = do + string keywordCard + space + string name + space + declaration d + +braces :: SparkFormatter () -> SparkFormatter () +braces f = do + modify (\s -> s {state_newline_before_deploy = True}) + + string "{" + newline + indented $ do + newline + f + newline + newline + string "}" + +string :: String -> SparkFormatter () +string s = tell s + +interspersed :: [String] -> String -> SparkFormatter () +interspersed [] _ = return () +interspersed [s] _ = string s +interspersed (s:ss) i = do + string s + string i + spaced ss + + +spaced :: [String] -> SparkFormatter () +spaced strs = interspersed strs " " + +space :: SparkFormatter () +space = onlyIf (not . conf_format_oneLine) $ string " " + + +newline :: SparkFormatter () +newline = do + onlyIf (not . conf_format_oneLine) $ string "\n" + ci <- gets state_current_indent + string $ replicate ci ' ' + +delimiter :: SparkFormatter () +delimiter = do + oneLine <- asks conf_format_oneLine + if oneLine + then string ";" + else newline + +indented :: SparkFormatter () -> SparkFormatter () +indented func = do + ind <- asks conf_format_indent + indent ind + func + indent (-ind) + +indent :: Int -> SparkFormatter () +indent c = do + ci <- gets state_current_indent + modify (\s -> s {state_current_indent = ci + c}) + +declarations :: [Declaration] -> SparkFormatter () +declarations = delimited declaration + +declaration :: Declaration -> SparkFormatter () +declaration (SparkOff cr) = do + string keywordSpark + space + cardReference cr +declaration (Deploy src dst k) = do + nbf <- gets state_newline_before_deploy + if nbf + then newline + else return () + quoted src + ls <- gets state_longest_src + onlyIf conf_format_lineUp $ string $ replicate (ls - length src) ' ' + string " " + mkind k + string " " + quoted dst + modify (\s -> s {state_newline_before_deploy = False}) +declaration (IntoDir dir) = do + string keywordInto + space + string dir +declaration (OutofDir dir) = do + string keywordOutof + space + string dir +declaration (DeployKindOverride k) = do + string keywordKindOverride + space + case k of + CopyDeployment -> string keywordCopy + LinkDeployment -> string keywordLink +declaration (Block ds) = do + ls <- gets state_longest_src + let m = maximum $ map srcLen ds + modify (\s -> s {state_longest_src = m} ) + braces $ declarations ds + modify (\s -> s {state_longest_src = ls} ) + onlyIf conf_format_trailingNewline newline + where + srcLen (Deploy src _ _) = length src + srcLen _ = 0 +declaration (Alternatives ds) = do + string keywordAlternatives + space + spaced ds + +quoted :: String -> SparkFormatter () +quoted str = do + alwaysQuote <- asks conf_format_alwaysQuote + if needsQuoting str || alwaysQuote + then do + string "\"" + string str + string "\"" + else do + string str + +needsQuoting :: String -> Bool +needsQuoting str = any (`elem` lineDelimiter ++ whitespaceChars ++ bracesChars) str + +onlyIf :: (SparkConfig -> Bool) -> SparkFormatter () -> SparkFormatter () +onlyIf conf func = do + b <- asks conf + if b + then func + else return () + +kind :: DeploymentKind -> SparkFormatter () +kind LinkDeployment = string linkKindSymbol +kind CopyDeployment = string copyKindSymbol + +mkind :: Maybe DeploymentKind -> SparkFormatter () +mkind (Just k) = kind k +mkind Nothing = do + onlyIf conf_format_lineUp space + string unspecifiedKindSymbol + +cardReference :: CardReference -> SparkFormatter () +cardReference (CardFile cfr) = cardFileReference cfr +cardReference (CardName cnr) = cardNameReference cnr + +cardFileReference :: CardFileReference -> SparkFormatter () +cardFileReference (CardFileReference fp mnr) = do + string keywordFile + string " " + string fp + case mnr of + Nothing -> return () + Just (CardNameReference cn) -> do + string " " + string cn + +cardNameReference :: CardNameReference -> SparkFormatter () +cardNameReference (CardNameReference name) = do + string keywordCard + string " " + string name + + +srcLen :: Deployment -> [Int] +srcLen (Put srcs _ _) = map length srcs + +maximums :: [[Int]] -> [Int] +maximums [[]] = [] +maximums lss = if all null lss + then [] + else (maximum $ map ahead lss):(maximums $ map atail lss) + where + ahead [] = 0 + ahead (l:_) = l + + atail [] = [] + atail (_:ls) = ls + +formatDeployments :: [Deployment] -> String +formatDeployments ds = unlines $ map (formatDeployment lens) ds + where lens = maximums $ map srcLen ds + +formatDeployment :: [Int] -> Deployment -> String +formatDeployment ms (Put srcs dst k) = unwords $ + [ + padded ms srcs + , kindSymbol k + , dst + ] + where + kindSymbol LinkDeployment = linkKindSymbol + kindSymbol CopyDeployment = copyKindSymbol + + padded :: [Int] -> [FilePath] -> String + padded [] [] = [] + padded (m:r) [] = replicate m ' ' ++ padded r [] + padded [] _ = [] + padded (m:r) (s:ss) = s ++ replicate (m - length s) ' ' ++ " " ++ padded r ss + +formatPreDeployments :: [(Deployment, PreDeployment)] -> String +formatPreDeployments pdps + = if null output then "Deployment is done already\n" else unlines output + where output = catMaybes $ map formatPreDeployment pdps + +{- +formatPreDeployments :: [(Deployment, PreDeployment)] -> String +formatPreDeployments ds = unlines $ zipStrs dests $ map (": " ++) ms + where + ms = map formatPreDeployment predeps + + dests = map (deployment_dst . fst) ds + predeps = map snd ds +-} + +formatPostDeployments :: [(Deployment, Maybe String)] -> String +formatPostDeployments ds = unlines $ zipStrs dests $ map (": " ++) ms + where + ms = map mstr predeps + + mstr Nothing = "done" + mstr (Just err) = err + + dests = map (deployment_dst . fst) ds + predeps = map snd ds + +formatPreDeployment :: (Deployment, PreDeployment) -> Maybe String +formatPreDeployment (d, (Ready _ _ _)) = Just $ deployment_dst d ++ ": " ++ "ready to deploy" +formatPreDeployment (_, AlreadyDone) = Nothing +formatPreDeployment (d, (Error str)) = Just $ deployment_dst d ++ ": " ++ unwords ["Error:", str] + + + +zipStrs :: [String] -> [String] -> [String] +zipStrs [] [] = [] +zipStrs [] ss = ss +zipStrs ss [] = ss +zipStrs (s:ss) (t:ts) = (s++t):(zipStrs ss ts) + + + + + diff --git a/src/Parser.hs b/src/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Parser.hs @@ -0,0 +1,297 @@ +module Parser where + +import Text.Parsec +import Text.Parsec.String + +import Data.List (find, isSuffixOf) + +import Constants +import Types + + +parseCardFileReference :: CardFileReference -> Sparker [Card] +parseCardFileReference (CardFileReference fp mnr) = do + css <- parseFile fp + case mnr of + Nothing -> return css + Just (CardNameReference cn) -> + case find (\s -> card_name s == cn) css of + Nothing -> throwError $ UnpredictedError $ unwords ["Did't find card", "\"" ++ cn ++ "\"", "in", fp] + Just c -> return [c] + + +parseFile :: FilePath -> Sparker [Card] +parseFile file = do + str <- liftIO $ readFile file + case parse sparkFile file str of + Left pe -> throwError $ ParseError pe + Right cs -> return cs + +--[ Language ]-- + +sparkFile :: Parser [Card] +sparkFile = do + clean <- eatComments + setInput clean + resetPosition + card `sepEndBy1` whitespace + +resetPosition :: Parser () +resetPosition = do + pos <- getPosition + setPosition $ setSourceColumn (setSourceLine pos 1) 1 + + +getFile :: Parser FilePath +getFile = do + pos <- getPosition + let file = sourceName pos + return file + +card :: Parser Card +card = do + whitespace + string keywordCard + whitespace + name <- cardName + whitespace + b <- block + whitespace + fp <- getFile + return $ Card name fp b + +cardName :: Parser CardName +cardName = try quotedIdentifier <|> try plainIdentifier "card name" + +declarations :: Parser [Declaration] +declarations = (inLineSpace declaration) `sepEndBy` delim + +declaration :: Parser Declaration +declaration = choice $ map try + [ + block + , alternatives + , sparkOff + , intoDir + , outOfDir + , deploymentKindOverride + , deployment + ] + +block :: Parser Declaration +block = do + ds <- inBraces $ inWhiteSpace declarations + return $ Block ds + "block" + +sparkOff :: Parser Declaration +sparkOff = do + string keywordSpark + linespace + ref <- cardReference + return $ SparkOff ref + "sparkoff" + +compilerCardReference :: Parser CompilerCardReference +compilerCardReference = unprefixedCardFileReference + +deployerCardReference :: Parser DeployerCardReference +deployerCardReference = goComp <|> goUncomp + where + goComp = compiledCardReference >>= return . DeployerCardCompiled + goUncomp = unprefixedCardFileReference >>= return . DeployerCardUncompiled + +compiledCardReference :: Parser CompiledCardReference +compiledCardReference = do + string "compiled" + skip linespace + fp <- filepath + return fp + +cardReference :: Parser CardReference +cardReference = try goName <|> try goFile "card reference" + where + goName = cardNameReference >>= return . CardName + goFile = cardFileReference >>= return . CardFile + +cardNameReference :: Parser CardNameReference +cardNameReference = do + string keywordCard + linespace + name <- cardName + return $ CardNameReference name + "card name reference" + + +cardFileReference :: Parser CardFileReference +cardFileReference = do + string keywordFile + skip linespace + unprefixedCardFileReference + +unprefixedCardFileReference :: Parser CardFileReference +unprefixedCardFileReference = do + fp <- filepath + linespace + mn <- optionMaybe $ try cardName + return $ case mn of + Nothing -> CardFileReference fp Nothing + Just cn -> CardFileReference fp (Just $ CardNameReference cn) + "card file reference" + +intoDir :: Parser Declaration +intoDir = do + string keywordInto + linespace + dir <- directory + return $ IntoDir dir + "into directory declaration" + +outOfDir :: Parser Declaration +outOfDir = do + string keywordOutof + linespace + dir <- directory + return $ OutofDir dir + "outof directory declaration" + +deploymentKindOverride :: Parser Declaration +deploymentKindOverride = do + string keywordKindOverride + linespace + kind <- try copy <|> link + return $ DeployKindOverride kind + "deployment kind override" + where + copy = string keywordCopy >> return CopyDeployment + link = string keywordLink >> return LinkDeployment + +shortDeployment :: Parser Declaration +shortDeployment = do + source <- filepath + return $ Deploy source source Nothing + +longDeployment :: Parser Declaration +longDeployment = do + source <- filepath + linespace + kind <- deploymentKind + linespace + dest <- filepath + return $ Deploy source dest kind + +deployment :: Parser Declaration +deployment = try longDeployment <|> shortDeployment + "deployment" + +deploymentKind :: Parser (Maybe DeploymentKind) +deploymentKind = try link <|> try copy <|> def + "deployment kind" + where + link = string linkKindSymbol >> return (Just LinkDeployment) + copy = string copyKindSymbol >> return (Just CopyDeployment) + def = string unspecifiedKindSymbol >> return Nothing + +alternatives :: Parser Declaration +alternatives = do + string keywordAlternatives + linespace + ds <- directory `sepBy1` linespace + return $ Alternatives ds + +-- [ FilePaths ]-- + +filepath :: Parser FilePath +filepath = try quotedIdentifier <|> plainIdentifier + +directory :: Parser Directory +directory = do + d <- filepath + return $ if "/" `isSuffixOf` d + then init d + else d + "directory" + + +--[ Comments ]-- + +comment :: Parser String +comment = lineComment <|> blockComment "Comments" + +lineComment :: Parser String +lineComment = do + skip $ string lineCommentStr + anyChar `manyTill` try eol + +blockComment :: Parser String +blockComment = do + skip $ string start + anyChar `manyTill` try (string stop) + where (start, stop) = blockCommentStrs + + + +notComment :: Parser String +notComment = manyTill anyChar (lookAhead ((skip comment) <|> eof)) + +eatComments :: Parser String +eatComments = do + optional comment + xs <- notComment `sepBy` comment + optional comment + let withoutComments = concat xs + return withoutComments + + +--[ Identifiers ]-- + +plainIdentifier :: Parser String +plainIdentifier = many1 $ noneOf $ quotesChar : lineDelimiter ++ whitespaceChars ++ bracesChars + +quotedIdentifier :: Parser String +quotedIdentifier = inQuotes $ many $ noneOf $ quotesChar:endOfLineChars + + +--[ Delimiters ]-- + +inBraces :: Parser a -> Parser a +inBraces = between (char '{') (char '}') + +inQuotes :: Parser a -> Parser a +inQuotes = between (char quotesChar) (char quotesChar) + +delim :: Parser String +delim = try (string lineDelimiter) <|> go + where + go = do + e <- eol + ws <- whitespace + return $ e ++ ws + + +--[ Whitespace ]-- + +inLineSpace :: Parser a -> Parser a +inLineSpace = between linespace linespace + +inWhiteSpace :: Parser a -> Parser a +inWhiteSpace = between whitespace whitespace + +linespace :: Parser String +linespace = many $ oneOf linespaceChars + +whitespace :: Parser String +whitespace = many $ oneOf whitespaceChars + +eol :: Parser String +eol = try (string "\n\r") + <|> try (string "\r\n") + <|> try (string "\n") + <|> string "\r" + "end of line" + + +--[ Utils ]-- + +skip :: Parser a -> Parser () +skip p = p >> return () diff --git a/src/Types.hs b/src/Types.hs new file mode 100644 --- /dev/null +++ b/src/Types.hs @@ -0,0 +1,358 @@ +{-# LANGUAGE OverloadedStrings #-} +module Types + ( + module Types + , module Control.Monad.Except + , module Control.Monad.IO.Class + , module Control.Monad.Reader + , module Control.Monad.State + , module Control.Monad.Writer + , module Control.Monad.Trans + , module Text.Parsec + ) where + +import Control.Applicative +import Control.Monad (mzero) +import Control.Monad.Except (ExceptT, runExceptT, throwError) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Reader (ReaderT, ask, asks, runReaderT) +import Control.Monad.State (StateT, get, gets, modify, put, + runStateT) +import Control.Monad.Trans (lift) +import Control.Monad.Writer (WriterT, runWriterT, tell) +import System.FilePath.Posix (takeExtension) + +import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), + object, (.:), (.=)) + +import Data.Binary (Binary (..), Get) +import qualified Data.Binary as B +import Data.ByteString (ByteString) +import Data.ByteString.Char8 (pack, unpack) +import System.Directory (Permissions (..)) +import Text.Parsec (ParseError) + +import Constants + +---[ Cards ]--- +type CardName = String +type Source = FilePath +type Destination = FilePath +type Directory = FilePath + +data Card = Card { + card_name :: CardName + , card_path :: FilePath + , card_content :: Declaration + } deriving (Show, Eq) + +---[ Declarations ]--- +data DeploymentKind = LinkDeployment + | CopyDeployment + deriving (Show, Eq) + +instance Binary DeploymentKind where + put LinkDeployment = B.put True + put CopyDeployment = B.put False + get = do + b <- B.get :: Get Bool + return $ if b + then LinkDeployment + else CopyDeployment + +instance Read DeploymentKind where + readsPrec _ "link" = [(LinkDeployment,"")] + readsPrec _ "copy" = [(CopyDeployment,"")] + readsPrec _ _ = [] + +instance FromJSON DeploymentKind where + parseJSON (String "link") = return LinkDeployment + parseJSON (String "copy") = return CopyDeployment + parseJSON _ = mzero + +instance ToJSON DeploymentKind where + toJSON LinkDeployment = String "link" + toJSON CopyDeployment = String "copy" + + + +data Declaration = SparkOff CardReference + | Deploy Source Destination (Maybe DeploymentKind) + | IntoDir Directory + | OutofDir Directory + | DeployKindOverride DeploymentKind + | Alternatives [Directory] + | Block [Declaration] + deriving (Show, Eq) + +---[ Card References ]-- + +-- Reference a card by name. +data CardNameReference = CardNameReference CardName + deriving (Show, Eq) + +-- Reference a card by the file it's in and therein potentially by a name reference +data CardFileReference = CardFileReference FilePath (Maybe CardNameReference) + deriving (Show, Eq) + +type CompilerCardReference = CardFileReference + +type CompiledCardReference = FilePath + +data DeployerCardReference = DeployerCardCompiled CompiledCardReference + | DeployerCardUncompiled CardFileReference + deriving (Show, Eq) + +type CheckerCardReference = DeployerCardReference + +instance Read CardFileReference where + readsPrec _ fp = case length (words fp) of + 1 -> [(CardFileReference fp Nothing ,"")] + 2 -> let [f, c] = words fp + in [(CardFileReference f (Just $ CardNameReference c), "")] + _ -> [] + +-- TODO refactor these +instance Read DeployerCardReference where + readsPrec _ fp = case length (words fp) of + 0 -> [] + 1 -> if takeExtension fp == ".sus" + then [(DeployerCardUncompiled (CardFileReference fp Nothing) ,"")] + else [(DeployerCardCompiled fp, "")] + 2 -> let [f, c] = words fp + in [(DeployerCardUncompiled (CardFileReference f (Just $ CardNameReference c)), "")] + _ -> [] + + +data CardReference = CardFile CardFileReference + | CardName CardNameReference + deriving (Show, Eq) + +---[ Base monad ]--- + +type Sparker = ExceptT SparkError (ReaderT SparkConfig IO) + +---[ Options ]--- + +type Options = (Dispatch, GlobalOptions) + +data GlobalOptions = GlobalOptions { + opt_lineUp :: Bool + , opt_indent :: Int + , opt_trailingNewline :: Bool + , opt_alwaysQuote :: Bool + , opt_compress :: Bool + , opt_output :: Maybe FilePath + , opt_format :: CompileFormat + , opt_kind :: Maybe DeploymentKind + , opt_overrride :: Maybe DeploymentKind + , opt_thoroughness :: CheckThoroughness + , opt_replace_links :: Bool + , opt_replace_files :: Bool + , opt_replace_directories :: Bool + , opt_replace :: Bool + , opt_debug :: Bool + } deriving (Show, Eq) + +---[ Instructions ]-- +type Instructions = (Dispatch, SparkConfig) + +---[ Config ]--- + +data SparkConfig = Config { + conf_format_lineUp :: Bool + , conf_format_indent :: Int + , conf_format_trailingNewline :: Bool + , conf_format_alwaysQuote :: Bool + , conf_format_oneLine :: Bool + , conf_compile_output :: Maybe FilePath + , conf_compile_format :: CompileFormat + , conf_compile_kind :: Maybe DeploymentKind + , conf_compile_override :: Maybe DeploymentKind + , conf_check_thoroughness :: CheckThoroughness + , conf_deploy_replace_links :: Bool + , conf_deploy_replace_files :: Bool + , conf_deploy_replace_directories :: Bool + , conf_debug :: Bool + } deriving (Show, Eq) + + +data CompileFormat = FormatBinary + | FormatText + | FormatJson + | FormatStandalone + deriving (Show, Eq) + +instance Read CompileFormat where + readsPrec _ "binary" = [(FormatBinary,"")] + readsPrec _ "text" = [(FormatText,"")] + readsPrec _ "json" = [(FormatJson,"")] + readsPrec _ "standalone" = [(FormatStandalone,"")] + readsPrec _ _ = [] + +data CheckThoroughness = ThoroughnessName + | ThoroughnessChecksum + | ThoroughnessContent + deriving (Show, Eq) + +instance Read CheckThoroughness where + readsPrec _ "name" = [(ThoroughnessName,"")] + readsPrec _ "checksum" = [(ThoroughnessChecksum,"")] + readsPrec _ "content" = [(ThoroughnessContent,"")] + readsPrec _ _ = [] + + +data SparkError = ParseError ParseError + | CompileError CompileError + | DeployError DeployError + | UnpredictedError String + deriving Show + +runSparker :: SparkConfig -> Sparker a -> IO (Either SparkError a) +runSparker conf func = runReaderT (runExceptT func) conf + +---[ Dispatching ]--- + +data Dispatch = DispatchParse FilePath + | DispatchFormat FilePath + | DispatchCompile CompilerCardReference + | DispatchCheck CheckerCardReference + | DispatchDeploy DeployerCardReference + deriving (Show, Eq) + + +---[ Compiling Types ]--- +data Deployment = Put { + deployment_srcs :: [FilePath] + , deployment_dst :: FilePath + , deployment_kind :: DeploymentKind + } + deriving Eq + +instance Binary Deployment where + put depl = do + B.put $ map pack $ deployment_srcs depl + B.put $ deployment_kind depl + B.put $ pack $ deployment_dst depl + get = do + bsrcs <- B.get :: Get [ByteString] + kind <- B.get :: Get DeploymentKind + dst <- B.get :: Get ByteString + return $ Put { + deployment_srcs = map unpack bsrcs + , deployment_kind = kind + , deployment_dst = unpack dst + } + +instance Read Deployment where + readsPrec _ str = [(Put { + deployment_srcs = srcs + , deployment_dst = dst + , deployment_kind = kind + }, "")] + where + srcs = (map unquote . reverse . drop 2 . reverse) ws + kind = case lookup (last $ init ws) [(linkKindSymbol, LinkDeployment), (copyKindSymbol, CopyDeployment)] of + Nothing -> error "unrecognised deployment kind symbol" + Just k -> k + dst = last ws + ws = words str + unquote = tail . init + +instance Show Deployment where + show dep = unwords $ srcs ++ [k,dst] + where + srcs = map quote $ deployment_srcs dep + k = case deployment_kind dep of + LinkDeployment -> linkKindSymbol + CopyDeployment -> copyKindSymbol + dst = quote $ deployment_dst dep + quote = (\s -> "\"" ++ s ++ "\"") + +instance FromJSON Deployment where + parseJSON (Object o) = Put <$> o .: "sources" + <*> o .: "destination" + <*> o .: "deployment kind" + parseJSON _ = mzero + +instance ToJSON Deployment where + toJSON depl = object [ + "sources" .= deployment_srcs depl + , "destination" .= deployment_dst depl + , "deployment kind" .= deployment_kind depl + ] + + + +type CompileError = String + +type SparkCompiler = StateT CompilerState (WriterT [Deployment] Sparker) + +type CompilerPrefix = [PrefixPart] + +data PrefixPart = Literal String + | Alts [String] + deriving (Show, Eq) + +runSparkCompiler :: CompilerState -> SparkCompiler a -> Sparker ((a,CompilerState), [Deployment]) +runSparkCompiler s func = runWriterT (runStateT func s) + + +data CompilerState = CompilerState { + state_current_card :: Card + , state_current_directory :: FilePath + , state_all_cards :: [Card] + , state_declarations_left :: [Declaration] + , state_deployment_kind_override :: Maybe DeploymentKind + , state_into :: Directory + , state_outof_prefix :: CompilerPrefix + } deriving (Show, Eq) + + + +---[ Deploying Types ]--- + +type SparkDeployer = StateT DeployerState Sparker +data DeployerState = DeployerState +data DeployError = PreDeployError [String] + | DuringDeployError [String] + | PostDeployError [String] + deriving (Show, Eq) + +runSparkDeployer :: DeployerState -> SparkDeployer a -> Sparker (a, DeployerState) +runSparkDeployer state func = runStateT func state + +data Diagnostics = NonExistent + | IsFile Permissions + | IsDirectory Permissions + | IsLink Permissions + | IsPipe + | IsSocket + | IsCharDevice + | IsBlockDevice + deriving (Show, Eq) + +data PreDeployment = Ready FilePath FilePath DeploymentKind + | AlreadyDone + | Error String + deriving (Show, Eq) + +data ID = Plain String + | Var String + deriving (Show, Eq) + + +---[ Pretty Types ]--- + +type SparkFormatter = StateT FormatterState (WriterT String Sparker) +data FormatterState = FormatterState { + state_current_indent :: Int + , state_longest_src :: Int + , state_newline_before_deploy :: Bool + } + deriving (Show, Eq) + +runSparkFormatter :: FormatterState -> SparkFormatter a -> Sparker ((a, FormatterState), String) +runSparkFormatter state func = runWriterT (runStateT func state) + + diff --git a/src/Utils.hs b/src/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Utils.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module Utils where + +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Reader (MonadReader) +import System.IO (hPutStrLn, stderr) +import System.Exit (exitFailure) +import Types + +{- +verbose :: (MonadReader SparkConfig m, MonadIO m) => String -> m () +verbose str = do + v <- asks conf_verbose + if v + then liftIO $ putStrLn str + else return () + +verboseOrDry :: (MonadReader SparkConfig m, MonadIO m) => String -> m () +verboseOrDry str = do + v <- asks conf_verbose + d <- asks conf_dry + if v || d + then liftIO $ putStrLn str + else return () +-} + +debug :: (MonadReader SparkConfig m, MonadIO m) => String -> m () +debug str = do + v <- asks conf_debug + if v + then liftIO $ putStrLn str + else return () + + +incase :: MonadReader SparkConfig m => (SparkConfig -> Bool) -> m () -> m () +incase bf func = do + b <- asks bf + if b + then func + else return () + +incaseElse :: MonadReader SparkConfig m => (SparkConfig -> Bool) -> m a -> m a -> m a +incaseElse bf funcif funcelse = do + b <- asks bf + if b + then funcif + else funcelse + +notImplementedYet :: Sparker () +notImplementedYet = throwError $ UnpredictedError "This feature is not implemented yet, it will be in the future, so be sure to check back in a newer version." + +die :: String -> IO a +die err = hPutStrLn stderr err >> exitFailure diff --git a/super-user-spark.cabal b/super-user-spark.cabal --- a/super-user-spark.cabal +++ b/super-user-spark.cabal @@ -1,5 +1,5 @@ name: super-user-spark -version: 0.2.0.0 +version: 0.2.0.1 license: MIT license-file: LICENSE description: Configure your dotfile deployment with a DSL. @@ -15,6 +15,16 @@ executable spark main-is: Main.hs hs-source-dirs: src + other-modules: Arguments + , Compiler + , Constants + , Deployer + , Dispatch + , Formatter + , Main + , Parser + , Types + , Utils ghc-options: -Wall -fwarn-unused-imports -fwarn-incomplete-patterns