super-user-spark 0.2.0.0 → 0.2.0.1
raw patch · 10 files changed
+1873/−1 lines, 10 files
Files
- src/Arguments.hs +191/−0
- src/Compiler.hs +219/−0
- src/Constants.hs +70/−0
- src/Deployer.hs +357/−0
- src/Dispatch.hs +33/−0
- src/Formatter.hs +283/−0
- src/Parser.hs +297/−0
- src/Types.hs +358/−0
- src/Utils.hs +54/−0
- super-user-spark.cabal +11/−1
+ src/Arguments.hs view
@@ -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." )
+ src/Compiler.hs view
@@ -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
+ src/Constants.hs view
@@ -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"
+ src/Deployer.hs view
@@ -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+
+ src/Dispatch.hs view
@@ -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
+ src/Formatter.hs view
@@ -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)+++++
+ src/Parser.hs view
@@ -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 ()
+ src/Types.hs view
@@ -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)++
+ src/Utils.hs view
@@ -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
super-user-spark.cabal view
@@ -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