super-user-spark 0.2.0.3 → 0.3.0.0
raw patch · 41 files changed
+3092/−1795 lines, 41 filesdep +QuickCheckdep +hspecdep +hspec-coredep −HTFdep −binarydep −zlibdep ~aesondep ~directory
Dependencies added: QuickCheck, hspec, hspec-core, pureMD5, super-user-spark
Dependencies removed: HTF, binary, zlib
Dependency ranges changed: aeson, directory
Files
- README.md +14/−0
- app/Main.hs +6/−0
- src/Arguments.hs +84/−89
- src/Check.hs +17/−0
- src/Check/Internal.hs +244/−0
- src/Check/Types.hs +50/−0
- src/Compiler.hs +72/−189
- src/Compiler/Internal.hs +64/−0
- src/Compiler/Types.hs +60/−0
- src/Compiler/Utils.hs +39/−0
- src/Config.hs +20/−0
- src/Config/Types.hs +39/−0
- src/Constants.hs +0/−3
- src/CoreTypes.hs +27/−0
- src/Deployer.hs +34/−343
- src/Deployer/Internal.hs +93/−0
- src/Deployer/Types.hs +35/−0
- src/Dispatch.hs +30/−21
- src/Dispatch/Types.hs +19/−0
- src/Formatter.hs +11/−18
- src/Language/Types.hs +59/−0
- src/Main.hs +0/−25
- src/Monad.hs +27/−0
- src/Parser.hs +13/−290
- src/Parser/Internal.hs +283/−0
- src/PreCompiler.hs +57/−0
- src/Seed.hs +25/−0
- src/Spark.hs +22/−0
- src/Types.hs +41/−330
- src/Utils.hs +23/−33
- super-user-spark.cabal +52/−18
- test/CheckSpec.hs +298/−0
- test/Compiler/Test.hs +0/−39
- test/CompilerSpec.hs +367/−0
- test/DeployerSpec.hs +263/−0
- test/EndToEndSpec.hs +71/−0
- test/MainTest.hs +11/−0
- test/Parser/Test.hs +0/−388
- test/ParserSpec.hs +498/−0
- test/SeedSpec.hs +24/−0
- test/TestMain.hs +0/−9
README.md view
@@ -1,4 +1,5 @@ # Super User Spark+[](https://travis-ci.org/NorfairKing/super-user-spark) A safe way to never worry about your beautifully configured system again @@ -18,3 +19,16 @@ - [NorfairKing](https://github.com/NorfairKing/sus-depot) - [plietar](https://github.com/plietar/dotfiles) - [mkirsche](https://github.com/mkirsche/sus-depot)+- [badi](https://github.com/badi/dotfiles/blob/master/deploy.sus)+- [tilal6991](https://github.com/tilal6991/.dotfiles)++## Contributing+Before contributing, make sure you installed the pre-commit tests:++```+spark deploy hooks.sus+```++## Found a problem?++Raise an issue or, even better, do a pull-request with a failing test!
+ app/Main.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import Spark++main :: IO ()+main = spark
src/Arguments.hs view
@@ -1,19 +1,20 @@ module Arguments where -import Data.Monoid (mconcat) import Options.Applicative import System.Environment (getArgs) +import Config+import Dispatch.Types 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+ 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@@ -21,7 +22,7 @@ configFromOptions :: GlobalOptions -> Either String SparkConfig configFromOptions go = Right conf where- conf = Config {+ conf = defaultConfig { 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@@ -31,27 +32,26 @@ , 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_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+ 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)+ 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@@ -117,75 +117,70 @@ 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." )+ <$> 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 FormatJson+ <> metavar "FORMAT"+ <> help "Compilation format default: json" )+ <*> 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" )+ <*> 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-all"+ <> short 'r'+ <> help "Equivalent to --replace-files --replace-directories --replace-links"+ )+ <*> switch+ ( long "debug"+ <> help "Show al debug information."+ )
+ src/Check.hs view
@@ -0,0 +1,17 @@+module Check (+ check+ , formatDeploymentChecks+ ) where++import Check.Internal+import Check.Types+import Compiler.Types+import Deployer.Internal++check :: [Deployment] -> IO [DeploymentCheckResult]+check ds = do+ completed <- completeDeployments ds+ diagnosed <- mapM diagnoseDeployment completed+ return $ map checkDeployment diagnosed++
+ src/Check/Internal.hs view
@@ -0,0 +1,244 @@+module Check.Internal where++import Check.Types+import Compiler.Types+import Constants+import CoreTypes+import qualified Data.ByteString as SB+import qualified Data.ByteString.Char8 as SBC+import qualified Data.ByteString.Lazy as LB+import qualified Data.Digest.Pure.MD5 as H (md5)+import Data.Maybe (catMaybes)+import System.Directory (getDirectoryContents)+import System.Exit (ExitCode (..))+import System.FilePath ((</>))+import System.Posix.Files (fileExist, getSymbolicLinkStatus,+ isBlockDevice, isCharacterDevice,+ isDirectory, isNamedPipe, isRegularFile,+ isSocket, isSymbolicLink,+ readSymbolicLink)+import System.Process (readProcess, system)++checkDeployment :: DiagnosedDeployment -> DeploymentCheckResult+checkDeployment (Diagnosed [] (D dst _ _) _)+ = ImpossibleDeployment [unwords ["No source for deployment with destination", dst]]+checkDeployment (Diagnosed srcs dst kind)+ = bestResult $ map (\src -> checkSingle src dst kind) srcs++bestResult :: [CheckResult] -> DeploymentCheckResult+bestResult cs+ | all impossible cs = ImpossibleDeployment $ map (\(Impossible s) -> s) cs+ | otherwise+ -- Will not be empty as per line above+ = case head $ dropWhile impossible cs of+ AlreadyDone -> DeploymentDone+ Ready i -> ReadyToDeploy i+ Dirty s i c -> DirtySituation s i c+ Impossible _ -> error "Cannot be the case"++impossible :: CheckResult -> Bool+impossible (Impossible _) = True+impossible _ = False++impossibleDeployment :: DeploymentCheckResult -> Bool+impossibleDeployment (ImpossibleDeployment _) = True+impossibleDeployment _ = False++dirtyDeployment :: DeploymentCheckResult -> Bool+dirtyDeployment (DirtySituation _ _ _) = True+dirtyDeployment _ = False++deploymentReadyToDeploy :: DeploymentCheckResult -> Bool+deploymentReadyToDeploy (ReadyToDeploy _) = True+deploymentReadyToDeploy _ = False++deploymentIsDone :: DeploymentCheckResult -> Bool+deploymentIsDone DeploymentDone = True+deploymentIsDone _ = False+++-- | Check a single (@source@, @destination@, @kind@) triple.+checkSingle :: DiagnosedFp -> DiagnosedFp -> DeploymentKind -> CheckResult+checkSingle (D src srcd srch) (D dst dstd dsth) kind =+ case (srcd, dstd, kind) of+ (IsFile , Nonexistent , _ ) -> ready++ (IsFile , IsFile , LinkDeployment)+ -> e ["Both the source:", src, "and the destination:", dst, "are files for a link deployment."]++ (IsFile , IsFile , CopyDeployment)+ -> if srch == dsth+ then AlreadyDone+ else e ["Both the source:", src, "and the destination:", dst, "are files for a copy deployment, but they are not equal."]++ (IsFile , IsDirectory , _)+ -> e ["The source: ", src, "is a file but the destination:", dst, "is a directory."]++ (IsFile , IsLinkTo l , LinkDeployment)+ -> if l == src+ then AlreadyDone+ else e ["The source:", src, "is a file and the destination:", dst, "is a link for a link deployment but the destination does not point to the source. Instead it points to:", l ++ "."]++ (IsFile , IsLinkTo _ , CopyDeployment)+ -> e ["The source:", src, "is a file and the destination:", dst, "is a link for a copy deployment."]++ (IsDirectory, Nonexistent , _ ) -> ready++ (IsDirectory, IsFile , _ )+ -> e ["The source:", src, "is a directory and the destination:", dst, "is a file."]++ (IsDirectory, IsDirectory , CopyDeployment)+ -> if srch == dsth+ then AlreadyDone+ else e ["The source:", src, "and destination:", dst, "are directories for a copy deployment, but they are not equal."]++ (IsDirectory, IsDirectory , LinkDeployment)+ -> e ["The source:", src, "and the destination:", dst, "are directories for a link deployment."]++ (IsDirectory, IsLinkTo l , LinkDeployment)+ -> if l == src+ then AlreadyDone+ else e ["The source:", src, "is a directory and the destination:", dst, "is a link for a link deployment but the destination does not point to the source. Instead it points to:", l ++ "."]++ (IsDirectory, IsLinkTo _ , CopyDeployment)+ -> e ["The source:", src, "is a directory and the destination:", dst, "is a link for a copy deployment."]++ (Nonexistent, _ , _ )+ -> i ["The source:", src, "does not exist."]++ (IsLinkTo _ , _ , _ )+ -> i ["The source:", src, "is a link."]++ (IsWeird , IsWeird , _ )+ -> i ["Both the source:", src, "and the destination:", dst, "are weird."]++ (IsWeird , _ , _ )+ -> i ["The source:", src, "is weird."]++ (_ , IsWeird , _ )+ -> i ["The destination:", dst, "is weird."]+ where+ ins = Instruction src dst kind+ ready = Ready ins+ i = Impossible . unlines+ e s = Dirty (unlines s) ins cins+ cins = case dstd of+ IsFile -> CleanFile dst+ IsLinkTo _ -> CleanLink dst+ IsDirectory -> CleanDirectory dst+ _ -> error "should not occur"++diagnoseDeployment :: Deployment -> IO DiagnosedDeployment+diagnoseDeployment (Put srcs dst kind) = do+ dsrcs <- mapM diagnose srcs+ ddst <- diagnose dst+ return $ Diagnosed dsrcs ddst kind++diagnose :: FilePath -> IO DiagnosedFp+diagnose fp = do+ d <- diagnoseFp fp+ hash <- hashFilePath fp+ return $ D fp d hash++diagnoseFp :: FilePath -> IO Diagnostics+diagnoseFp fp = do+ e <- fileExist fp+ if e+ then do+ s <- getSymbolicLinkStatus fp+ if isBlockDevice s || isCharacterDevice s || isSocket s || isNamedPipe s+ then return IsWeird+ else do+ if isSymbolicLink s+ then do+ point <- readSymbolicLink fp+ return $ IsLinkTo point+ else if isDirectory s+ then return IsDirectory+ else if isRegularFile s+ then return IsFile+ else error $ "File " ++ fp ++ " was neither a block device, a character device, a socket, a named pipe, a symbolic link, a directory or a regular file"+ else do+ -- If a link exists, but it points to something that doesn't exist, it is considered as non-existent by `fileExist`+ es <- system $ unwords ["test", "-L", fp]+ case es of+ ExitSuccess -> do+ -- Need to do a manual call because readSymbolicLink fails for nonexistent destinations+ point <- readProcess "readlink" [fp] ""+ return $ IsLinkTo $ init point -- remove newline+ ExitFailure _ -> return Nonexistent+++md5 :: SB.ByteString -> HashDigest+md5 bs = H.md5 $ LB.fromStrict bs++-- | Hash a filepath so that two filepaths with the same contents have the same hash+hashFilePath :: FilePath -> IO HashDigest+hashFilePath fp = do+ d <- diagnoseFp fp+ case d of+ IsFile -> hashFile fp+ IsDirectory -> hashDirectory fp+ IsLinkTo _ -> return $ md5 SB.empty+ IsWeird -> return $ md5 SB.empty+ Nonexistent -> return $ md5 SB.empty++hashFile :: FilePath -> IO HashDigest+hashFile fp = md5 <$> SB.readFile fp++hashDirectory :: FilePath -> IO HashDigest+hashDirectory fp = do+ rawContents <- getDirectoryContents fp+ let contents = map (fp </>) . filter (\f -> not $ f == "." || f == "..") $ rawContents+ hashes <- mapM hashFilePath contents+ let hashbs = map (SBC.pack . show) hashes+ return $ md5 $ SB.concat hashbs+++formatDeploymentChecks :: [(Deployment, DeploymentCheckResult)] -> String+formatDeploymentChecks dss+ = if null output+ then "Deployment is done already."+ else unlines output +++ if all (impossibleDeployment . snd) dss+ then "Deployment is impossible."+ else "Deployment is possible."+ where output = catMaybes $ map formatDeploymentCheck dss+++formatDeploymentCheck :: (Deployment, DeploymentCheckResult) -> Maybe String+formatDeploymentCheck (_, (ReadyToDeploy is)) = Just $ "READY: " ++ formatInstruction is+formatDeploymentCheck (_, DeploymentDone) = Nothing+formatDeploymentCheck (d, ImpossibleDeployment ds)+ = Just $ "IMPOSSIBLE: "+ ++ deployment_dst d+ ++ " cannot be deployed:\n"+ ++ unlines ds ++ "\n"+formatDeploymentCheck (d, (DirtySituation str is c))+ = Just $ "DIRTY: "+ ++ deployment_dst d+ ++ "\n"+ ++ str+ ++ "planned: "+ ++ formatInstruction is+ ++ "\n"+ ++ "cleanup needed:\n"+ ++ formatCleanupInstruction c+ ++ "\n"++formatInstruction :: Instruction -> String+formatInstruction (Instruction src dst k) = unwords $+ [ src+ , kindSymbol k+ , dst+ ]+ where+ kindSymbol LinkDeployment = linkKindSymbol+ kindSymbol CopyDeployment = copyKindSymbol++formatCleanupInstruction :: CleanupInstruction -> String+formatCleanupInstruction (CleanFile fp) = "remove file " ++ fp+formatCleanupInstruction (CleanDirectory dir) = "remove directory " ++ dir+formatCleanupInstruction (CleanLink link) = "remove link " ++ link++
+ src/Check/Types.hs view
@@ -0,0 +1,50 @@+module Check.Types where++import CoreTypes+import Data.Digest.Pure.MD5 (MD5Digest)++type HashDigest = MD5Digest++data Diagnostics+ = Nonexistent+ | IsFile+ | IsDirectory+ | IsLinkTo FilePath+ | IsWeird+ deriving (Show, Eq)++data DiagnosedFp = D+ { diagnosedFilePath :: FilePath+ , diagnosedDiagnostics :: Diagnostics+ , diagnosedHashDigest :: HashDigest+ } deriving (Show, Eq)++data Instruction = Instruction FilePath FilePath DeploymentKind+ deriving (Show, Eq)++data CleanupInstruction+ = CleanFile FilePath+ | CleanDirectory FilePath+ | CleanLink FilePath+ deriving (Show, Eq)++data DeploymentCheckResult+ = DeploymentDone -- ^ Done already+ | ReadyToDeploy Instruction -- ^ Immediately possible+ | DirtySituation String Instruction CleanupInstruction -- ^ Possible after cleanup of destination+ | ImpossibleDeployment [String] -- ^ Entirely impossible+ deriving (Show, Eq)++data CheckResult+ = AlreadyDone -- ^ Done already+ | Ready Instruction -- ^ Immediately possible+ | Dirty String Instruction CleanupInstruction -- ^ Possible after cleanup+ | Impossible String -- ^ Entirely impossible+ deriving (Show, Eq)++data DiagnosedDeployment = Diagnosed+ { diagnosedSrcs :: [DiagnosedFp]+ , diagnosedDst :: DiagnosedFp+ , diagnosedKind :: DeploymentKind+ } deriving (Show, Eq)+
src/Compiler.hs view
@@ -1,219 +1,102 @@ module Compiler where -import Codec.Compression.GZip (bestCompression, compressLevel,- compressWith, decompress,- defaultCompressParams)+import Compiler.Internal+import Compiler.Types+import Control.Monad (when) 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 Language.Types+import Parser+import PreCompiler+import System.FilePath (takeDirectory, (</>)) 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+compileJob :: CardFileReference -> Sparker [Deployment]+compileJob cr@(CardFileReference root _) = go "" cr+ where+ go :: FilePath -> CardFileReference -> Sparker [Deployment]+ go base (CardFileReference fp mcn) = do+ sf <- parseFile fp+ let scope = sparkFileCards sf+ unit <- case mcn of+ Nothing -> case scope of+ [] -> throwError $ CompileError $ "No cards found for compilation in file:" ++ fp+ (first:_) -> return first+ Just (CardNameReference name) -> do+ case find (\c -> cardName c == name) scope of+ Nothing -> throwError $ CompileError $ unwords ["Card", name, "not found for compilation."]+ Just cu -> return cu + -- Inject base outofDir+ let injected = injectBase unit -compile :: Card -> [Card] -> Sparker [Deployment]-compile card allCards = do- initial <- initialState card allCards- ((_,_),dps) <- runSparkCompiler initial compileDeployments- return dps+ -- Precompile checks+ let pces = preCompileChecks injected+ when (not . null $ pces) $ throwError $ PreCompileError pces + -- Compile this unit+ (deps, crfs) <- embedPureCompiler $ compileUnit injected++ -- Compile the rest of the units+ restDeps <- fmap concat+ $ mapM compileCardReference+ $ map (resolveCardReferenceRelativeTo fp) crfs++ return $ deps ++ restDeps+ where++ injectBase :: Card -> Card+ injectBase c@(Card name s) | null base = c+ | otherwise = Card name $ Block [OutofDir base, s]++ stripRoot :: FilePath -> FilePath+ stripRoot orig = case stripPrefix (takeDirectory root) orig of+ Nothing -> orig+ Just ('/':new) -> new+ Just new -> new++ composeBases :: FilePath -> FilePath -> FilePath+ composeBases base [] = base+ composeBases _ base2 = takeDirectory (stripRoot base2)+++ compileCardReference :: CardReference -> Sparker [Deployment]+ compileCardReference (CardFile cfr@(CardFileReference base2 _)) = go (composeBases base base2) cfr+ compileCardReference (CardName cnr) = go base (CardFileReference fp $ Just cnr)++resolveCardReferenceRelativeTo :: FilePath -> CardReference -> CardReference+resolveCardReferenceRelativeTo fp (CardFile (CardFileReference cfp mcn)) = CardFile $ CardFileReference (takeDirectory fp </> cfp) mcn+resolveCardReferenceRelativeTo _ cn = cn++embedPureCompiler :: PureCompiler a -> Sparker a+embedPureCompiler func = withExceptT CompileError $ mapExceptT (mapReaderT idToIO) func+ where+ idToIO :: Identity a -> IO a+ idToIO = return . runIdentity+ 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+ liftIO $ case form of 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}+ Nothing -> BS.putStrLn bs+ Just fp -> BS.writeFile fp bs+ _ -> error $ "unrecognized format" 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-+ _ -> error $ "unrecognized format" - 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/Compiler/Internal.hs view
@@ -0,0 +1,64 @@+module Compiler.Internal where++import Compiler.Types+import Compiler.Utils+import Language.Types+import System.FilePath ((</>))+import Types++compileUnit :: Card -> PureCompiler ([Deployment], [CardReference])+compileUnit card = do+ initSt <- initialState+ execWriterT $ evalStateT (compileDecs [cardContent card]) initSt++compileDecs :: [Declaration] -> InternalCompiler ()+compileDecs = mapM_ compileDec+++compileDec :: Declaration -> InternalCompiler ()+compileDec (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+ outof <- gets state_outof_prefix+ into <- gets state_into++ let alternates = resolvePrefix $ outof ++ [sources src]+ let destination = into </> dst++ addDeployment $ Put alternates destination resultKind+++compileDec (SparkOff cr) = addCardRef cr+++compileDec (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} )+++compileDec (OutofDir dir) = do+ op <- gets state_outof_prefix+ modify (\s -> s {state_outof_prefix = op ++ [Literal dir]})+++compileDec (DeployKindOverride kind) = do+ modify (\s -> s { state_deployment_kind_override = Just kind })+++compileDec (Block ds) = do+ before <- get+ compileDecs ds+ put before+++compileDec (Alternatives ds) = do+ op <- gets state_outof_prefix+ modify (\s -> s { state_outof_prefix = op ++ [Alts ds] })+
+ src/Compiler/Types.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE OverloadedStrings #-}+module Compiler.Types where++import Constants+import Control.Monad (mzero)+import CoreTypes+import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), object,+ (.:), (.=))+import Language.Types+import Monad+import Types++data Deployment = Put+ { deployment_srcs :: [FilePath]+ , deployment_dst :: FilePath+ , deployment_kind :: DeploymentKind+ } deriving Eq++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 CompilerPrefix = [PrefixPart]++data PrefixPart = Literal String+ | Alts [String]+ deriving (Show, Eq)++data CompilerState = CompilerState+ { state_deployment_kind_override :: Maybe DeploymentKind+ , state_into :: Directory+ , state_outof_prefix :: CompilerPrefix+ } deriving (Show, Eq)++type PrecompileError = String++type ImpureCompiler = ExceptT CompileError (ReaderT SparkConfig IO)+type PureCompiler = ExceptT CompileError (ReaderT SparkConfig Identity)+type Precompiler = WriterT [PrecompileError] Identity+type InternalCompiler = StateT CompilerState (WriterT ([Deployment], [CardReference]) PureCompiler)+
+ src/Compiler/Utils.hs view
@@ -0,0 +1,39 @@+module Compiler.Utils where++import Compiler.Types+import Language.Types+import System.FilePath ((</>))+import Types+++initialState :: PureCompiler CompilerState+initialState = do+ override <- asks conf_compile_kind+ return $ CompilerState {+ state_deployment_kind_override = override+ , state_into = ""+ , state_outof_prefix = []+ }++addDeployment :: Deployment -> InternalCompiler ()+addDeployment d = tell ([d], [])++addCardRef :: CardReference -> InternalCompiler ()+addCardRef c = tell ([], [c])++sources :: FilePath -> PrefixPart+sources fp@('.':f) = Alts [fp, f]+sources fp = Literal fp++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+
+ src/Config.hs view
@@ -0,0 +1,20 @@+module Config where++import Config.Types++defaultConfig :: SparkConfig+defaultConfig = Config {+ conf_format_lineUp = False+ , conf_format_indent = 2+ , conf_format_trailingNewline = True+ , conf_format_alwaysQuote = False+ , conf_format_oneLine = False+ , conf_compile_output = Nothing+ , conf_compile_format = FormatJson+ , conf_compile_kind = Nothing+ , conf_compile_override = Nothing+ , conf_deploy_replace_links = False+ , conf_deploy_replace_files = False+ , conf_deploy_replace_directories = False+ , conf_debug = False+ }
+ src/Config/Types.hs view
@@ -0,0 +1,39 @@+module Config.Types where++import CoreTypes++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_deploy_replace_links :: Bool+ , conf_deploy_replace_files :: Bool+ , conf_deploy_replace_directories :: Bool+ , conf_debug :: Bool+ } deriving (Show, Eq)+++data CompileFormat = FormatJson+ deriving (Show, Eq)++instance Read CompileFormat where+ readsPrec _ "json" = [(FormatJson,"")]+ readsPrec _ _ = []++data CheckThoroughness = ThoroughnessName+ | ThoroughnessChecksum+ | ThoroughnessContent+ deriving (Show, Eq)++instance Read CheckThoroughness where+ readsPrec _ "name" = [(ThoroughnessName,"")]+ readsPrec _ "checksum" = [(ThoroughnessChecksum,"")]+ readsPrec _ "content" = [(ThoroughnessContent,"")]+ readsPrec _ _ = []+
src/Constants.hs view
@@ -6,9 +6,6 @@ keywordSpark :: String keywordSpark = "spark" -keywordGit :: String-keywordGit = "git"- keywordFile :: String keywordFile = "file"
+ src/CoreTypes.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE OverloadedStrings #-}+module CoreTypes where++import Control.Monad (mzero)+import Data.Aeson (FromJSON (..), ToJSON (..), Value (..))++type Directory = FilePath++-- | The kind of a deployment+data DeploymentKind = LinkDeployment+ | CopyDeployment+ deriving (Show, Eq)++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"+
src/Deployer.hs view
@@ -1,357 +1,48 @@-{-# 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 Check+import Check.Internal+import Check.Types+import Compiler.Types+import Control.Monad (forM_, when)+import Deployer.Internal+import Monad 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]+deploy :: [(Deployment, DeploymentCheckResult)] -> Sparker ()+deploy dcrs = do+ let crs = map snd dcrs+ -- Check for impossible deployments+ when (any impossibleDeployment crs) $+ err dcrs "Deployment is impossible." + -- Clean up the situation+ forM_ crs $ \d -> do+ case d of+ DirtySituation _ _ cis -> performClean cis+ _ -> return () -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+ -- Check again+ let ds = map fst dcrs+ dcrs2 <- liftIO $ check ds -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+ -- Error if the cleaning is not done now.+ when (any (impossibleDeployment ||| dirtyDeployment) dcrs2) $+ err (zip ds dcrs2) "Situation was not entirely clean after attemted cleanup. Maybe you forgot to enable cleanups (--replace-all)?" - 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."]+ -- Perform deployments+ liftIO $ mapM_ performDeployment $ map (\(ReadyToDeploy i) -> i) $ filter deploymentReadyToDeploy dcrs2 + -- Check one last time.+ dcrsf <- liftIO $ check ds+ when (any (not . deploymentIsDone) dcrsf) $ do+ err (zip ds dcrsf) "Something went wrong during deployment. It's not done yet." 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+ err :: [(Deployment, DeploymentCheckResult)] -> String -> Sparker ()+ err dcrs text = do+ liftIO $ putStrLn $ formatDeploymentChecks dcrs+ throwError $ DeployError text -replaceHome :: FilePath -> IO FilePath-replaceHome path = do- home <- getHomeDirectory- return $ if "~" `isPrefixOf` path- then home </> drop 2 path- else path
+ src/Deployer/Internal.hs view
@@ -0,0 +1,93 @@+module Deployer.Internal where++import Check.Types+import Compiler.Types+import Data.List (isPrefixOf)+import Data.Text (pack)+import Deployer.Types+import Shelly (cp_r, fromText, shelly)+import System.Directory (getHomeDirectory,+ removeDirectoryRecursive, removeFile)+import System.Environment (getEnvironment)+import System.FilePath (normalise, (</>))+import System.FilePath.Posix (dropFileName)+import System.Posix.Files (createSymbolicLink, removeLink)+import Types+import Utils++completeDeployments :: [Deployment] -> IO [Deployment]+completeDeployments ds = do+ home <- getHomeDirectory+ env <- getEnvironment+ case mapM (completeDeployment home env) ds of+ Left err -> die err+ Right fp -> return fp++type Environment = [(String, String)]+type HomeDir = FilePath++completeDeployment :: HomeDir -> Environment -> Deployment -> Either String Deployment+completeDeployment home env (Put srcs dst kind) = do+ csrcs <- mapM (complete home env) srcs+ cdst <- complete home env dst+ return $ Put csrcs cdst kind++complete :: HomeDir -> Environment -> FilePath -> Either String FilePath+complete home env fp = do+ let ids = parseId fp+ strs <- mapM (replaceId env) ids+ let completed = map (replaceHome home) strs+ return $ normalise $ concat completed++parseId :: FilePath -> [ID]+parseId [] = []+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 :: Environment -> ID -> Either String FilePath+replaceId _ (Plain str) = return str+replaceId e (Var str) = do+ case lookup str e of+ Nothing -> Left $ unwords ["variable", str, "could not be resolved from environment."]+ Just fp -> Right fp++replaceHome :: HomeDir -> FilePath -> FilePath+replaceHome home path+ = if "~" `isPrefixOf` path+ then home </> drop 2 path+ else path++performClean :: CleanupInstruction -> Sparker ()+performClean (CleanFile fp) = incase conf_deploy_replace_files $ rmFile fp+performClean (CleanDirectory fp) = incase conf_deploy_replace_directories $ rmDir fp+performClean (CleanLink fp) = incase conf_deploy_replace_links $ unlink fp++unlink :: FilePath -> Sparker ()+unlink fp = liftIO $ removeLink fp++rmFile :: FilePath -> Sparker ()+rmFile fp = liftIO $ removeFile fp++rmDir :: FilePath -> Sparker ()+rmDir fp = liftIO $ removeDirectoryRecursive fp+++performDeployment :: Instruction -> IO ()+performDeployment (Instruction source destination LinkDeployment) = link source destination+performDeployment (Instruction source destination CopyDeployment) = copy source destination++copy :: FilePath -> FilePath -> IO ()+copy src dst = do+ createDirectoryIfMissing upperDir+ shelly $ cp_r (fromText $ pack src) (fromText $ pack dst)+ where upperDir = dropFileName dst++link :: FilePath -> FilePath -> IO ()+link src dst = do+ createDirectoryIfMissing upperDir+ createSymbolicLink src dst+ where upperDir = dropFileName dst+
+ src/Deployer/Types.hs view
@@ -0,0 +1,35 @@+module Deployer.Types where++import Language.Types+import Monad+import System.FilePath.Posix (takeExtension)+import Types++data DeployerCardReference+ = DeployerCardCompiled FilePath+ | DeployerCardUncompiled CardFileReference+ deriving (Show, Eq)++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)), "")]+ _ -> []++type SparkDeployer = StateT DeployerState Sparker+data DeployerState = DeployerState++data PreDeployment = Ready FilePath FilePath DeploymentKind+ | AlreadyDone+ | Error String+ deriving (Show, Eq)++data ID = Plain String+ | Var String+ deriving (Show, Eq)++
src/Dispatch.hs view
@@ -1,33 +1,42 @@-module Dispatch where+module Dispatch (dispatch) where +import Check import Compiler+import Compiler.Types+import Control.Monad (void) import Deployer+import Deployer.Types+import Dispatch.Types import Formatter import Parser+import Seed import Types dispatch :: Dispatch -> Sparker ()-dispatch (DispatchParse fp) = parseFile fp >> return () -- Just parse, throw away the results.+dispatch (DispatchParse fp) = do+ void $ parseFile fp -- Just parse, throw away the results.+ dispatch (DispatchFormat fp) = do- cards <- parseFile fp- str <- formatCards cards+ sf <- parseFile fp+ str <- formatSparkFile sf liftIO $ putStrLn str-dispatch (DispatchCompile (CardFileReference fp mcnr)) = do- cards <- parseFile fp- deployments <- compileRef cards mcnr++dispatch (DispatchCompile cfr) = do+ deployments <- compileJob cfr 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 (DispatchCheck dcr) = do+ deps <- compileDeployerCardRef dcr+ seeded <- seedByCompiledCardRef dcr deps+ dcrs <- liftIO $ check seeded+ liftIO $ putStrLn $ formatDeploymentChecks $ zip seeded dcrs+ 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+ deps <- compileDeployerCardRef dcr+ seeded <- seedByCompiledCardRef dcr deps+ dcrs <- liftIO $ check seeded+ deploy $ zip seeded dcrs++compileDeployerCardRef :: DeployerCardReference -> Sparker [Deployment]+compileDeployerCardRef (DeployerCardCompiled fp) = inputCompiled fp+compileDeployerCardRef (DeployerCardUncompiled cfr) = compileJob cfr
+ src/Dispatch/Types.hs view
@@ -0,0 +1,19 @@+module Dispatch.Types where++import Types++import Deployer.Types+import Language.Types+++type Instructions = (Dispatch, SparkConfig)++data Dispatch = DispatchParse FilePath+ | DispatchFormat FilePath+ | DispatchCompile CardFileReference+ | DispatchCheck DeployerCardReference+ | DispatchDeploy DeployerCardReference+ deriving (Show, Eq)++type Options = (Dispatch, GlobalOptions)+
src/Formatter.hs view
@@ -1,13 +1,16 @@ module Formatter where -import Data.List (intersperse)-import Data.Maybe (catMaybes)+import Data.List (intersperse)+import Data.Maybe (catMaybes) +import Compiler.Types import Constants+import Deployer.Types+import Language.Types import Types -formatCards :: [Card] -> Sparker String-formatCards cs = do+formatSparkFile :: SparkFile -> Sparker String+formatSparkFile (SparkFile _ cs) = do initial <- initialState (_, res) <- runSparkFormatter initial (cards cs) return res@@ -35,7 +38,7 @@ card :: Card -> SparkFormatter ()-card (Card name _ d) = do+card (Card name d) = do string keywordCard space string name@@ -224,9 +227,9 @@ formatDeployment :: [Int] -> Deployment -> String formatDeployment ms (Put srcs dst k) = unwords $ [- padded ms srcs- , kindSymbol k- , dst+ padded ms srcs+ , kindSymbol k+ , dst ] where kindSymbol LinkDeployment = linkKindSymbol@@ -242,16 +245,6 @@ 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
+ src/Language/Types.hs view
@@ -0,0 +1,59 @@+module Language.Types where++import CoreTypes++-- * Cards++type CardName = String+type Source = FilePath+type Destination = FilePath++data Card = Card+ { cardName :: CardName+ , cardContent :: Declaration+ } deriving (Show, Eq)++-- ** Declarations++-- | A declaration in a card+data Declaration+ = SparkOff CardReference -- ^ Spark off another card+ | Deploy Source Destination (Maybe DeploymentKind) -- ^ Deploy from source to destination+ | IntoDir Directory -- ^ Deploy into a directory+ | OutofDir Directory -- ^ Deploy outof a directory+ | DeployKindOverride DeploymentKind -- ^ Override the deployment kind+ | Alternatives [Directory] -- ^ Provide a list of alternative sources+ | Block [Declaration] -- ^ A scoped block of declarations+ deriving (Show, Eq)++-- * Card references++-- | Reference a card by name (inside a file)+data CardNameReference = CardNameReference CardName+ deriving (Show, Eq)++-- | Reference a card by the file it is in and therein potentially by a name reference+data CardFileReference = CardFileReference FilePath (Maybe CardNameReference)+ deriving (Show, Eq)+++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), "")]+ _ -> []+++-- | Union card reference+data CardReference = CardFile CardFileReference+ | CardName CardNameReference+ deriving (Show, Eq)+++-- * Card files+data SparkFile = SparkFile+ { sparkFilePath :: FilePath+ , sparkFileCards :: [Card]+ } deriving (Show, Eq)+
− src/Main.hs
@@ -1,25 +0,0 @@-module Main where--import Arguments-import Dispatch-import Types-import Utils--main :: IO ()-main = do- (di, config) <- getInstructions-- er <- runSparker config $ dispatch di- case er of- Left err -> die $ showError err- Right _ -> return ()--showError :: SparkError -> String-showError (ParseError err) = show err-showError (CompileError err) = err-showError (UnpredictedError err) = "Panic: " ++ err-showError (DeployError err) =- case err of- PreDeployError ss -> unlines ss- DuringDeployError ss -> unlines ss- PostDeployError ss -> unlines ss
+ src/Monad.hs view
@@ -0,0 +1,27 @@+module Monad where++import Control.Monad.Except (ExceptT, runExceptT)+import Control.Monad.Reader (ReaderT, runReaderT)+import Text.Parsec (ParseError)++import Config.Types++-- | The base monad+type Sparker = ExceptT SparkError (ReaderT SparkConfig IO)++runSparker :: SparkConfig -> Sparker a -> IO (Either SparkError a)+runSparker conf func = runReaderT (runExceptT func) conf++++data SparkError = ParseError ParseError+ | PreCompileError [PreCompileError]+ | CompileError CompileError+ | DeployError DeployError+ | UnpredictedError String+ deriving (Show, Eq)++type CompileError = String+type PreCompileError = String+type DeployError = String+
src/Parser.hs view
@@ -1,297 +1,20 @@ module Parser where -import Text.Parsec-import Text.Parsec.String--import Data.List (find, isSuffixOf)--import Constants+import Control.Exception (try)+import Language.Types+import Parser.Internal 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 :: FilePath -> Sparker SparkFile 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 ]--+ esf <- liftIO $ try $ parseFileIO file+ case esf of+ Left ioe -> throwError $ UnpredictedError $ show (ioe :: IOError)+ Right sf -> do+ case sf of+ Left pe -> throwError $ ParseError pe+ Right cs -> return cs -skip :: Parser a -> Parser ()-skip p = p >> return ()+parseFileIO :: FilePath -> IO (Either ParseError SparkFile)+parseFileIO file = (liftIO $ readFile file) >>= return . parseCardFile file
+ src/Parser/Internal.hs view
@@ -0,0 +1,283 @@+module Parser.Internal where++import Constants+import Data.List (isSuffixOf)+import Deployer.Types+import Language.Types+import Text.Parsec+import Text.Parsec.String+import Types+++parseCardFile :: FilePath -> String -> Either ParseError SparkFile+parseCardFile f s = do+ cs <- parseFromSource sparkFile f s+ return $ SparkFile f cs++parseFromSource :: Parser a -> FilePath -> String -> Either ParseError a+parseFromSource = parse+++--[ Language ]--++sparkFile :: Parser [Card]+sparkFile = do+ clean <- eatComments+ setInput clean+ resetPosition+ cards++cards :: Parser [Card]+cards = card `sepEndBy1` whitespace++resetPosition :: Parser ()+resetPosition = do+ pos <- getPosition+ setPosition $ setSourceColumn (setSourceLine pos 1) 1++card :: Parser Card+card = do+ whitespace+ skip $ string keywordCard+ whitespace+ name <- cardNameP+ whitespace+ b <- block+ whitespace+ return $ Card name b++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+ skip $ string keywordSpark+ linespace+ ref <- cardReference+ return $ SparkOff ref+ <?> "sparkoff"++compilerCardReference :: Parser CardFileReference+compilerCardReference = unprefixedCardFileReference++deployerCardReference :: Parser DeployerCardReference+deployerCardReference = goComp <|> goUncomp+ where+ goComp = compiledCardReference >>= return . DeployerCardCompiled+ goUncomp = unprefixedCardFileReference >>= return . DeployerCardUncompiled++compiledCardReference :: Parser FilePath+compiledCardReference = do+ skip $ string "compiled"+ skip linespace+ filepath++cardReference :: Parser CardReference+cardReference = try goName <|> try goFile <?> "card reference"+ where+ goName = cardNameReference >>= return . CardName+ goFile = cardFileReference >>= return . CardFile++cardNameReference :: Parser CardNameReference+cardNameReference = do+ skip $ string keywordCard+ linespace+ name <- cardNameP+ return $ CardNameReference name+ <?> "card name reference"++cardNameP :: Parser CardName+cardNameP = identifier <?> "card name"++cardFileReference :: Parser CardFileReference+cardFileReference = do+ skip $ string keywordFile+ skip linespace+ unprefixedCardFileReference++unprefixedCardFileReference :: Parser CardFileReference+unprefixedCardFileReference = do+ fp <- filepath+ linespace+ mn <- optionMaybe $ try cardNameP+ return $ case mn of+ Nothing -> CardFileReference fp Nothing+ Just cn -> CardFileReference fp (Just $ CardNameReference cn)+ <?> "card file reference"++intoDir :: Parser Declaration+intoDir = do+ skip $ string keywordInto+ linespace+ dir <- directory+ return $ IntoDir dir+ <?> "into directory declaration"++outOfDir :: Parser Declaration+outOfDir = do+ skip $ string keywordOutof+ linespace+ dir <- directory+ return $ OutofDir dir+ <?> "outof directory declaration"++deploymentKindOverride :: Parser Declaration+deploymentKindOverride = do+ skip $ 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 <- try directory <|> 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+ skip $ string keywordAlternatives+ linespace+ ds <- directory `sepBy1` linespace+ return $ Alternatives ds++-- [ FilePaths ]--++filepath :: Parser FilePath+filepath = do+ i <- identifier <?> "Filepath"+ if "/" `isSuffixOf` i+ then unexpected "slash at the end"+ else return i++directory :: Parser Directory+directory = filepath <?> "Directory"+++--[ Comments ]--++comment :: Parser String+comment = try lineComment <|> try blockComment <?> "Comment"++lineComment :: Parser String+lineComment = (<?> "Line comment") $ do+ skip $ try $ string lineCommentStr+ anyChar `manyTill` eol++blockComment :: Parser String+blockComment = (<?> "Block comment") $ do+ skip $ try $ 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 ]--+identifier :: Parser String+identifier = try quotedIdentifier <|> plainIdentifier++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 ()+delim = try (skip $ string lineDelimiter) <|> go+ where+ go = do+ eol+ whitespace+++--[ Whitespace ]--++inLineSpace :: Parser a -> Parser a+inLineSpace = between linespace linespace++inWhiteSpace :: Parser a -> Parser a+inWhiteSpace = between whitespace whitespace++linespace :: Parser ()+linespace = skip $ many $ oneOf linespaceChars++whitespace :: Parser ()+whitespace = skip $ many $ oneOf whitespaceChars++eol :: Parser ()+eol = skip newline+ where+ newline =+ try (string "\r\n")+ <|> try (string "\n")+ <|> string "\r"+ <?> "end of line"+++--[ Utils ]--++skip :: Parser a -> Parser ()+skip p = p >> return ()
+ src/PreCompiler.hs view
@@ -0,0 +1,57 @@+module PreCompiler where++import Compiler.Types+import Language.Types+import Types+import Utils++preCompileChecks :: Card -> [PreCompileError]+preCompileChecks c = runIdentity $ execWriterT $ cleanCard c++dirty :: String -> Precompiler ()+dirty s = tell ["Precompilation check failed: " ++ s]++cleanCard :: Card -> Precompiler ()+cleanCard (Card name d) = do+ cleanCardName name+ cleanDeclaration d++cleanDeclaration :: Declaration -> Precompiler ()+cleanDeclaration (Deploy src dst _) = do+ cleanFilePath src+ cleanFilePath dst++cleanDeclaration (SparkOff cr) = cleanCardReference cr+cleanDeclaration (IntoDir dir) = cleanFilePath dir+cleanDeclaration (OutofDir dir) = cleanFilePath dir+cleanDeclaration (DeployKindOverride _) = return () -- Nothing can go wrong.+cleanDeclaration (Alternatives fs) = mapM_ cleanFilePath fs+cleanDeclaration (Block ds) = mapM_ cleanDeclaration ds++cleanCardReference :: CardReference -> Precompiler ()+cleanCardReference (CardFile cfr) = cleanCardFileReference cfr+cleanCardReference (CardName cnr) = cleanCardNameReference cnr++cleanCardFileReference :: CardFileReference -> Precompiler ()+cleanCardFileReference (CardFileReference fp mcnr) = do+ cleanFilePath fp+ case mcnr of+ Nothing -> return ()+ Just cnr -> cleanCardNameReference cnr++cleanCardNameReference :: CardNameReference -> Precompiler ()+cleanCardNameReference (CardNameReference cn) = cleanCardName cn++cleanCardName :: CardName -> Precompiler ()+cleanCardName n+ | containsNewline n = dirty $ "Card name contains newline character(s): " ++ n+ | otherwise = return ()++cleanFilePath :: FilePath -> Precompiler ()+cleanFilePath [] = dirty "Empty filepath"+cleanFilePath fp+ | containsNewline fp =+ dirty $ "Filepath contains newline character(s): " ++ fp+ | containsMultipleConsequtiveSlashes fp =+ dirty $ "Filepath contains multiple consequtive slashes: " ++ fp+ | otherwise = return ()
+ src/Seed.hs view
@@ -0,0 +1,25 @@+module Seed where++import Compiler.Types+import Deployer.Types+import Language.Types+import Monad+import System.Directory (getCurrentDirectory)+import System.FilePath (takeDirectory, (</>))+import Types++seedByCompiledCardRef :: DeployerCardReference -> [Deployment] -> Sparker [Deployment]+seedByCompiledCardRef (DeployerCardCompiled fp) = seedByRel fp+seedByCompiledCardRef (DeployerCardUncompiled (CardFileReference fp _)) = seedByRel fp++seedByRel :: FilePath -> [Deployment] -> Sparker [Deployment]+seedByRel file ds = do+ cur <- liftIO $ getCurrentDirectory+ let reldir = takeDirectory file+ return $ seed (cur </> reldir) ds++seed :: FilePath -> [Deployment] -> [Deployment]+seed fp = map (\d -> d { deployment_srcs = map seedsrc $ deployment_srcs d })+ where+ seedsrc :: FilePath -> FilePath+ seedsrc = (fp </>)
+ src/Spark.hs view
@@ -0,0 +1,22 @@+module Spark (spark) where++import Arguments+import Dispatch+import Types+import Utils++spark :: IO ()+spark = do+ (di, config) <- getInstructions++ er <- runSparker config $ dispatch di+ case er of+ Left err -> die $ showError err+ Right _ -> return ()++showError :: SparkError -> String+showError (ParseError err) = show err+showError (PreCompileError errs) = unlines errs+showError (CompileError err) = err+showError (UnpredictedError err) = "Panic: " ++ err+showError (DeployError err) = err
src/Types.hs view
@@ -1,358 +1,69 @@-{-# LANGUAGE OverloadedStrings #-} module Types ( module Types+ , module CoreTypes+ , module Monad+ , module Config.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 Control.Monad.Identity , module Text.Parsec++ , module Debug.Trace ) 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,+import Control.Monad.Except (ExceptT, mapExceptT, runExceptT,+ throwError, withExceptT)+import Control.Monad.Identity (Identity, runIdentity)+import Control.Monad.IO.Class (MonadIO (..), liftIO)+import Control.Monad.Reader (MonadReader (..), ReaderT, ask, asks,+ mapReaderT, runReaderT)+import Control.Monad.State (MonadState (..), StateT, evalStateT,+ execStateT, 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 Control.Monad.Writer (MonadWriter (..), WriterT, execWriterT,+ runWriterT, tell)+import Debug.Trace -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)+import Config.Types+import CoreTypes+import Monad ---[ 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+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_replace_links :: Bool+ , opt_replace_files :: Bool+ , opt_replace_directories :: Bool+ , opt_replace :: Bool+ , opt_debug :: Bool } 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)+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
@@ -2,43 +2,20 @@ {-# 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 Control.Monad (when)+import Data.List (isInfixOf)+import qualified System.Directory as D (createDirectoryIfMissing)+import System.Exit (exitFailure)+import System.IO (hPutStrLn, stderr) 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 ()-+debug str = incase (asks conf_debug) $ liftIO $ putStrLn str incase :: MonadReader SparkConfig m => (SparkConfig -> Bool) -> m () -> m () incase bf func = do b <- asks bf- if b- then func- else return ()+ when b func incaseElse :: MonadReader SparkConfig m => (SparkConfig -> Bool) -> m a -> m a -> m a incaseElse bf funcif funcelse = do@@ -47,8 +24,21 @@ 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++containsNewline :: String -> Bool+containsNewline f = any (\c -> elem c f) ['\n', '\r']++containsMultipleConsequtiveSlashes :: String -> Bool+containsMultipleConsequtiveSlashes = isInfixOf "//"++(&&&) :: (a -> Bool) -> (a -> Bool) -> a -> Bool+(&&&) f g = \a -> f a && g a++(|||) :: (a -> Bool) -> (a -> Bool) -> a -> Bool+(|||) f g = \a -> f a || g a++createDirectoryIfMissing :: FilePath -> IO ()+createDirectoryIfMissing = D.createDirectoryIfMissing True+
super-user-spark.cabal view
@@ -1,5 +1,5 @@ name: super-user-spark-version: 0.2.0.3+version: 0.3.0.0 license: MIT license-file: LICENSE description: Configure your dotfile deployment with a DSL.@@ -11,57 +11,91 @@ extra-source-files: README.md cabal-version: >=1.10 --executable spark- main-is: Main.hs+library hs-source-dirs: src- other-modules: Arguments+ exposed-modules: Arguments+ , Check+ , Check.Internal+ , Check.Types , Compiler+ , Compiler.Internal+ , Compiler.Types+ , Compiler.Utils+ , Config.Types+ , Config , Constants+ , CoreTypes , Deployer+ , Deployer.Types+ , Deployer.Internal , Dispatch+ , Dispatch.Types , Formatter- , Main+ , Language.Types+ , Monad , Parser+ , Parser.Internal+ , PreCompiler+ , Seed+ , Spark , Types , Utils+ ghc-options: -Wall -fwarn-unused-imports -fwarn-incomplete-patterns -fno-warn-unused-do-bind -fno-warn-name-shadowing+ build-depends: base >= 4.6 && < 4.9- , HTF >= 0.13 && < 0.14- , aeson >= 0.8 && < 0.9+ , aeson >= 0.8 && < 0.11 , aeson-pretty >= 0.7 && < 0.8- , binary >= 0.7 && < 0.8 , bytestring >= 0.10 && < 0.11- , directory >= 1.2 && < 1.3+ , directory >= 1.2.5 && < 1.3 , filepath >= 1.4 && < 1.5 , mtl >= 2.2 && < 2.3 , optparse-applicative >= 0.11 && < 0.12 , parsec >= 3.1.9 && < 3.2 , process >= 1.2 && < 1.3+ , pureMD5 >= 2.1 && < 2.2 , shelly >= 1.6 && < 1.7 , text >= 1.2 && < 1.3 , transformers >= 0.4 && < 0.5 , unix >= 2.7 && < 2.8- , zlib >= 0.6 && < 0.7 default-language: Haskell2010++executable spark+ main-is: Main.hs+ hs-source-dirs: app+ ghc-options: -Wall+ -fwarn-unused-imports+ -fwarn-incomplete-patterns+ -fno-warn-unused-do-bind+ -fno-warn-name-shadowing+ -threaded -rtsopts -with-rtsopts=-N+ build-depends: base >= 4.6 && < 4.9+ , super-user-spark+ default-language: Haskell2010 test-suite spark-tests type: exitcode-stdio-1.0- main-is: TestMain.hs+ main-is: MainTest.hs hs-source-dirs: src, test- other-modules: Parser.Test- , Compiler.Test+ other-modules: CheckSpec+ , ParserSpec+ , CompilerSpec+ , DeployerSpec+ , SeedSpec+ , EndToEndSpec build-depends: base >= 4.6 && < 4.9- , HTF >= 0.13 && < 0.14+ , super-user-spark+ , hspec >= 2.2 && < 2.3+ , hspec-core >= 2.2 && < 2.3 , HUnit >= 1.2 && < 1.3- , aeson >= 0.8 && < 0.9+ , QuickCheck >= 2.8 && < 2.9+ , aeson >= 0.8 && < 0.11 , aeson-pretty >= 0.7 && < 0.8- , binary >= 0.7 && < 0.8 , bytestring >= 0.10 && < 0.11 , directory >= 1.2 && < 1.3 , filepath >= 1.4 && < 1.5@@ -69,10 +103,10 @@ , optparse-applicative >= 0.11 && < 0.12 , parsec >= 3.1 && < 3.2 , process >= 1.2 && < 1.3+ , pureMD5 >= 2.1 && < 2.2 , shelly >= 1.6 && < 1.7 , text >= 1.2 && < 1.3 , transformers >= 0.4 && < 0.5 , unix >= 2.7 && < 2.8- , zlib >= 0.6 && < 0.7 default-language: Haskell2010
+ test/CheckSpec.hs view
@@ -0,0 +1,298 @@+module CheckSpec where++import Check.Gen ()+import Check.Internal+import Check.TestUtils+import Check.Types+import Compiler.Types+import Control.Monad (forM_)+import CoreTypes+import qualified Data.ByteString as SB+import Parser.Gen+import System.Directory (removeDirectoryRecursive, removeFile,+ withCurrentDirectory)+import System.Posix.Files+import Test.Hspec+import Test.QuickCheck+import TestUtils+import Utils++spec :: Spec+spec = do+ diagnoseSpec+ checkSpec+ hashSpec++diagnoseSpec :: Spec+diagnoseSpec = do+ let sandbox = "test_sandbox"+ let setup = createDirectoryIfMissing sandbox+ let teardown = removeDirectoryRecursive sandbox++ beforeAll_ setup $ afterAll_ teardown $ do+ describe "diagnoseDeployment" $ do+ it "retains the filepaths and deploymentkind that it diagnoses for very simple filepaths" $ do+ once $ forAll (resize 5 $ listOf generateWord) $ \srcs -> do+ forAll generateWord $ \dst -> do+ forAll arbitrary $ \kind -> do+ (Diagnosed dsrcs ddst dkind) <- diagnoseDeployment $ Put srcs dst kind+ map diagnosedFilePath dsrcs `shouldBe` srcs+ diagnosedFilePath ddst `shouldBe` dst+ dkind `shouldBe` kind++ pend+++ describe "diagnose" $ do+ it "retains the filepath that it diagnoses for very simple filepaths" $ do+ once $ forAll generateWord $ \fp -> do+ (D dfp _ _) <- diagnose fp+ dfp `shouldBe` fp++ pend+++ describe "diagnoseFp" $ do+ it "figures out this test file" $ do+ withCurrentDirectory sandbox $ do+ let file = "test.txt"+ writeFile file "This is a test"+ diagnoseFp file `shouldReturn` IsFile+ removeFile file+ diagnoseFp file `shouldReturn` Nonexistent++ it "figures out this test directory" $ do+ withCurrentDirectory sandbox $ do+ let dir = "testdir"+ createDirectoryIfMissing dir+ diagnoseFp dir `shouldReturn` IsDirectory+ removeDirectoryRecursive dir+ diagnoseFp dir `shouldReturn` Nonexistent++ it "figures out this test symbolic link with a destination" $ do+ withCurrentDirectory sandbox $ do+ let link = "testlink"+ let file = "testfile"+ writeFile file "This is a test"+ createSymbolicLink file link++ diagnoseFp file `shouldReturn` IsFile+ diagnoseFp link `shouldReturn` IsLinkTo file++ removeLink link+ removeFile file++ diagnoseFp link `shouldReturn` Nonexistent++ it "figures out this test symbolic link without a destination" $ do+ withCurrentDirectory sandbox $ do+ let link = "testlink"+ let file = "testfile"+ createSymbolicLink file link++ diagnoseFp file `shouldReturn` Nonexistent+ diagnoseFp link `shouldReturn` IsLinkTo file++ removeLink link++ diagnoseFp file `shouldReturn` Nonexistent+ diagnoseFp link `shouldReturn` Nonexistent++ it "figures out that /dev/null is weird" $ do+ diagnoseFp "/dev/null" `shouldReturn` IsWeird++ it "figures out that /dev/random is weird" $ do+ diagnoseFp "/dev/random" `shouldReturn` IsWeird++checkSpec :: Spec+checkSpec = parallel $ do+ checkSingleSpec+ checkDeploymentSpec++checkDeploymentSpec :: Spec+checkDeploymentSpec = do+ describe "checkDeployment" $ do+ it "says 'impossible' for deployments with an empty list of sources" $ do+ forAll arbitrary $ \dst ->+ forAll arbitrary $ \kind ->+ shouldBeImpossible' $ Diagnosed [] dst kind++ it "says 'impossible' for deployments where all singles are impossible" $ do+ forAll (arbitrary `suchThat` (\(Diagnosed srcs dst kind) -> all (\src -> isImpossible $ checkSingle src dst kind) srcs)) $ \dd ->+ shouldBeImpossible' dd+++ it "gives the same result as bestResult (just with a better error for empty lists)" $ do+ property $ \dd@(Diagnosed srcs dst kind) ->+ case (bestResult (map (\src -> checkSingle src dst kind) srcs), checkDeployment dd) of+ (ImpossibleDeployment r1, ImpossibleDeployment r2) -> length r1 `shouldSatisfy` (<= (length r2))+ (r1, r2) -> r1 `shouldBe` r2++ describe "bestResult" $ do+ it "says 'impossible' if all checkresults are impossible" $ do+ forAll (arbitrary `suchThat` all isImpossible) shouldBeImpossibleDeployment++ it "says 'done' if the first non-impossible in 'done'" $ do+ forAll (arbitrary `suchThat` (any (not . isImpossible)+ &&& (isDone . head . dropWhile isImpossible)))+ $ \dd -> bestResult dd `shouldSatisfy` deploymentIsDone++ it "says 'dirty' if the first non-impossible in 'dirty'" $ do+ forAll (arbitrary `suchThat` (any (not . isImpossible)+ &&& (isDirty . head . dropWhile isImpossible)))+ $ \dd -> bestResult dd `shouldSatisfy` dirtyDeployment++ it "says 'ready' if the first non-impossible in 'ready'" $ do+ forAll (arbitrary `suchThat` (any (not . isImpossible)+ &&& (isReady . head . dropWhile isImpossible)))+ $ \dd -> bestResult dd `shouldSatisfy` deploymentReadyToDeploy+++checkSingleSpec :: Spec+checkSingleSpec = describe "checkSingle" $ do+ it "says 'impossible' if the source does not exist" $ do+ forAll (arbitraryWith Nonexistent) $ \src ->+ forAll arbitrary $ \dst ->+ forAll arbitrary $ \kind ->+ shouldBeImpossible src dst kind++ it "says 'ready' if the source is a file and the destination does not exist" $ do+ forAll (arbitraryWith IsFile) $ \src ->+ forAll (arbitraryWith Nonexistent) $ \dst ->+ forAll arbitrary $ \kind ->+ shouldBeReady src dst kind++ it "says 'dirty' if both the source and destination are files and it's a link deployment" $ do+ forAll (arbitraryWith IsFile) $ \src ->+ forAll (arbitraryWith IsFile) $ \dst ->+ shouldBeDirty src dst LinkDeployment $ CleanFile $ diagnosedFilePath dst++ it "says 'done' if both the source and destination are files and it's a copy deployment and the files are equal" $ do+ forAll arbitrary $ \src ->+ forAll arbitrary $ \dst ->+ forAll arbitrary $ \h1 ->+ shouldBeDone (D src IsFile h1) (D dst IsFile h1) CopyDeployment++ it "says 'dirty' if both the source and destination are files and it's a copy deployment but the files are unequal" $ do+ forAll arbitrary $ \src ->+ forAll arbitrary $ \dst ->+ forAll arbitrary $ \h1 ->+ forAll (arbitrary `suchThat` (/= h1)) $ \h2 ->+ shouldBeDirty (D src IsFile h1) (D dst IsFile h2) CopyDeployment $ CleanFile dst++ it "says 'dirty' if the source is a file and the destination is a directory" $ do+ forAll (arbitraryWith IsFile) $ \src ->+ forAll (arbitraryWith IsDirectory) $ \dst ->+ forAll arbitrary $ \kind ->+ shouldBeDirty src dst kind $ CleanDirectory $ diagnosedFilePath dst++ it "says 'dirty' if the source is a file and the destination is a link for a link deployment but the destination doesn't point to the source" $ do+ forAll (arbitraryWith IsFile) $ \src@(D srcp _ _) ->+ forAll (arbitrary `suchThat` (/= srcp)) $ \l ->+ forAll (arbitraryWith $ IsLinkTo l) $ \dst ->+ shouldBeDirty src dst LinkDeployment $ CleanLink $ diagnosedFilePath dst++ it "says 'done' if the source is a file and the destination is a link for a link deployment and the destination points to the source" $ do+ forAll (arbitraryWith IsFile) $ \src@(D srcp _ _) ->+ forAll (arbitraryWith $ IsLinkTo srcp) $ \dst ->+ shouldBeDone src dst LinkDeployment++ it "says 'dirty' if the source is a file and the destination is a link for a copy deployment" $ do+ forAll (arbitraryWith IsFile) $ \src ->+ forAll arbitrary $ \l ->+ forAll (arbitraryWith $ IsLinkTo l) $ \dst ->+ shouldBeDirty src dst CopyDeployment $ CleanLink $ diagnosedFilePath dst++ it "says 'ready' if the source is a directory and the destination does not exist" $ do+ forAll (arbitraryWith IsDirectory) $ \src ->+ forAll (arbitraryWith Nonexistent) $ \dst ->+ forAll arbitrary $ \kind ->+ shouldBeReady src dst kind++ it "says 'dirty' if the source is a directory and the destination is a file" $ do+ forAll (arbitraryWith IsDirectory) $ \src ->+ forAll (arbitraryWith IsFile) $ \dst ->+ forAll arbitrary $ \kind ->+ shouldBeDirty src dst kind $ CleanFile $ diagnosedFilePath dst++ it "says 'dirty' if both the source and destination are directories for a link deployment" $ do+ forAll (arbitraryWith IsDirectory) $ \src ->+ forAll (arbitraryWith IsDirectory) $ \dst ->+ shouldBeDirty src dst LinkDeployment $ CleanDirectory $ diagnosedFilePath dst++ it "says 'done' if both the source and destination are directories and it's a copy deployment and the directories are equal" $ do+ forAll arbitrary $ \src ->+ forAll arbitrary $ \dst ->+ forAll arbitrary $ \h1 ->+ shouldBeDone (D src IsDirectory h1) (D dst IsDirectory h1) CopyDeployment++ it "says 'dirty' if both the source and destination are directories and it's a copy deployment but the directories are unequal" $ do+ forAll arbitrary $ \src ->+ forAll arbitrary $ \dst ->+ forAll arbitrary $ \h1 ->+ forAll (arbitrary `suchThat` (/= h1)) $ \h2 ->+ shouldBeDirty (D src IsDirectory h1) (D dst IsDirectory h2) CopyDeployment $ CleanDirectory dst++ it "says 'dirty' if the source is a directory and the destination is a link for a link deployment but the destination doesn't point to the source" $ do+ forAll (arbitraryWith IsDirectory) $ \src@(D srcp _ _) ->+ forAll (arbitrary `suchThat` (/= srcp)) $ \l ->+ forAll (arbitraryWith $ IsLinkTo l) $ \dst ->+ shouldBeDirty src dst LinkDeployment $ CleanLink $ diagnosedFilePath dst++ it "says 'done' if the source is a directory and the destination is a link for a link deployment and the destination points to the source" $ do+ forAll (arbitraryWith IsDirectory) $ \src@(D srcp _ _) ->+ forAll (arbitraryWith $ IsLinkTo srcp) $ \dst ->+ shouldBeDone src dst LinkDeployment++ it "says 'dirty' if the source is a directory and the destination is a link for a copy deployment" $ do+ forAll (arbitraryWith IsDirectory) $ \src ->+ forAll arbitrary $ \l ->+ forAll (arbitraryWith $ IsLinkTo l) $ \dst ->+ shouldBeDirty src dst CopyDeployment $ CleanLink $ diagnosedFilePath dst++ it "says 'dirty' if the source is a link" $ do+ forAll arbitrary $ \l ->+ forAll (arbitraryWith $ IsLinkTo l) $ \src ->+ forAll arbitrary $ \dst ->+ forAll arbitrary $ \kind ->+ shouldBeImpossible src dst kind+++ it "says 'dirty' for a weird source" $ do+ forAll (arbitraryWith IsWeird) $ \src ->+ forAll arbitrary $ \dst ->+ forAll arbitrary $ \kind ->+ shouldBeImpossible src dst kind++ it "says 'dirty' for a weird destination" $ do+ forAll arbitrary $ \src ->+ forAll (arbitraryWith IsWeird) $ \dst ->+ forAll arbitrary $ \kind ->+ shouldBeImpossible src dst kind++ it "works for these unit tests" $ do+ pending++++hashSpec :: Spec+hashSpec = do+ tooManyFilesTest++tooManyFilesTest :: Spec+tooManyFilesTest = do+ let sandbox = "test_sandbox"+ let setup = createDirectoryIfMissing sandbox+ let teardown = removeDirectoryRecursive sandbox+ let aLot = 20000 :: Int+ let setupALotOfFiles = do+ forM_ [1..aLot] $ \i ->+ writeFile (sandbox ++ "/file" ++ show i) $ "This is file " ++ show i ++ ".\n"++ beforeAll_ setup $ afterAll_ teardown $ do+ describe "hashFilePath" $ do+ beforeAll_ setupALotOfFiles $ do+ it ("has no problem with hashing a directory of " ++ show aLot ++ " files") $ do+ hashFilePath "test_sandbox" `shouldNotReturn` md5 SB.empty++
− test/Compiler/Test.hs
@@ -1,39 +0,0 @@-{-# OPTIONS_GHC -F -pgmF htfpp #-}-module Compiler.Test (htf_thisModulesTests) where--import Test.Framework-import Test.HUnit (Assertion)--import Compiler-import Types--{--compilerTest :: [Declaration] -> [Deployment] -> Assertion-compilerTest dc dp = assertEqual dp $ compile dc--test_compiler_empty = compilerTest [] []--test_compiler_single_deploy = compilerTest [Deploy "bashrc" ".bashrc" LinkDeployment] [Link "bashrc" ".bashrc"]---test_compiler_single_spark = compilerTest-test_compiler_single_into = compilerTest [IntoDir "~/.xmonad"] []-test_compiler_single_outof = compilerTest [OutofDir "bash"] []--test_compiler_into = compilerTest- [IntoDir "~"- ,Deploy "bashrc" ".bashrc" LinkDeployment- ,IntoDir "~/.xmonad"- ,Deploy "xmonad.hs" "xmonad.hs" LinkDeployment]- [Link "bashrc" "~/.bashrc", Link "xmonad.hs" "~/.xmonad/xmonad.hs"]--test_compiler_outof = compilerTest- [OutofDir "bash"- ,Deploy "bashrc" "~/.bashrc" LinkDeployment]- [Link "bash/bashrc" "~/.bashrc"]--test_compiler_both = compilerTest- [IntoDir "~/.xmonad"- ,OutofDir "xmonad"- ,Deploy "xmonad.hs" "xmonad.hs" LinkDeployment]- [Link "xmonad/xmonad.hs" "~/.xmonad/xmonad.hs"]--}-
+ test/CompilerSpec.hs view
@@ -0,0 +1,367 @@+module CompilerSpec where++import Compiler+import Compiler.TestUtils+import Compiler.Types+import Config+import CoreTypes+import Data.Either (isLeft, isRight)+import Data.List (isPrefixOf)+import Language.Gen ()+import Language.Types+import PreCompiler+import System.FilePath.Posix (takeExtension, (<.>), (</>))+import Test.Hspec+import Test.QuickCheck+import TestUtils+import Types+import Utils++spec :: Spec+spec = parallel $ do+ singleCompileDecSpec+ precompileSpec+ hopTests+ exactTests+ compilerBlackBoxTests+++precompileSpec :: Spec+precompileSpec = describe "pre-compilation" $ do+ cleanContentSpec++cleanContentSpec :: Spec+cleanContentSpec = do+ let validFp = arbitrary `suchThat` cleanBy cleanFilePath++ describe "cleanCard" $ do+ it "doesn't report any card with valid content and a valid name" $ do+ forAll (arbitrary `suchThat` cleanBy cleanCardName) $ \cn ->+ forAll (arbitrary `suchThat` cleanBy cleanDeclaration) $ \cc ->+ Card cn cc `shouldSatisfy` cleanBy cleanCard++ describe "cleanCardName" $ do+ pend++ it "doesn't report an emty card name" $ do+ "" `shouldSatisfy` cleanBy cleanCardName++ it "reports card names with newlines" $ do+ forAll (arbitrary `suchThat` containsNewlineCharacter) $ \s ->+ s `shouldNotSatisfy` cleanBy cleanCardName++ describe "cleanDeclaration" $ do+ describe "Deploy" $ do+ it "doesn't report Deploy declarations with valid filepaths" $ do+ forAll validFp $ \src ->+ forAll validFp $ \dst ->+ forAll arbitrary $ \kind ->+ Deploy src dst kind `shouldSatisfy` cleanBy cleanDeclaration++ it "reports Deploy declarations with an invalid source" $ do+ forAll (arbitrary `suchThat` (not . cleanBy cleanFilePath)) $ \src ->+ forAll validFp $ \dst ->+ forAll arbitrary $ \kind ->+ Deploy src dst kind `shouldNotSatisfy` cleanBy cleanDeclaration++ it "reports Deploy declarations with an invalid destination" $ do+ forAll validFp $ \src ->+ forAll (arbitrary `suchThat` (not . cleanBy cleanFilePath)) $ \dst ->+ forAll arbitrary $ \kind ->+ Deploy src dst kind `shouldNotSatisfy` cleanBy cleanDeclaration++ pend++ describe "SparkOff" $ do+ it "reports SparkOff declarations with an invalid card reference" $ do+ forAll (arbitrary `suchThat` (not . cleanBy cleanCardReference)) $ \cr ->+ SparkOff cr `shouldNotSatisfy` cleanBy cleanDeclaration++ it "doesn't report SparkOff declarations with a valid card reference" $ do+ forAll (arbitrary `suchThat` cleanBy cleanCardReference) $ \cr ->+ SparkOff cr `shouldSatisfy` cleanBy cleanDeclaration++ pend++ describe "IntoDir" $ do+ it "reports IntoDir declarations with an invalid filepath" $ do+ forAll (arbitrary `suchThat` (not . cleanBy cleanFilePath)) $ \fp ->+ IntoDir fp `shouldNotSatisfy` cleanBy cleanDeclaration++ it "doesn't report IntoDir declarations with a valid filepath" $ do+ forAll (arbitrary `suchThat` cleanBy cleanFilePath) $ \fp ->+ IntoDir fp `shouldSatisfy` cleanBy cleanDeclaration++ pend++ describe "OutofDir" $ do+ it "reports OutofDir declarations with an invalid filepath" $ do+ forAll (arbitrary `suchThat` (not . cleanBy cleanFilePath)) $ \fp ->+ OutofDir fp `shouldNotSatisfy` cleanBy cleanDeclaration++ it "doesn't report OutofDir declarations with a valid filepath" $ do+ forAll (arbitrary `suchThat` cleanBy cleanFilePath) $ \fp ->+ OutofDir fp `shouldSatisfy` cleanBy cleanDeclaration++ pend++ describe "DeployKindOverride" $ do+ it "doesn't report any deployment kind override declarations" $ do+ forAll arbitrary $ \kind ->+ DeployKindOverride kind `shouldSatisfy` cleanBy cleanDeclaration++ pend++ describe "Alternatives" $ do+ it "reports alternatives declarations with as much as a single invalid filepath" $ do+ forAll (arbitrary `suchThat` (any $ not . cleanBy cleanFilePath)) $ \fs ->+ Alternatives fs `shouldNotSatisfy` cleanBy cleanDeclaration++ it "doesn't report alternatives declarations with valid filepaths" $ do+ forAll (arbitrary `suchThat` (all $ cleanBy cleanFilePath)) $ \fs ->+ Alternatives fs `shouldSatisfy` cleanBy cleanDeclaration++ pend++ describe "Block" $ do+ it "reports block declarations with as much as a single invalid declaration inside" $ do+ forAll (arbitrary `suchThat` (any $ not . cleanBy cleanDeclaration)) $ \ds ->+ Block ds `shouldNotSatisfy` cleanBy cleanDeclaration++ it "doesn't report any block declarations with valid declarations inside" $ do+ forAll (arbitrary `suchThat` (all $ cleanBy cleanDeclaration)) $ \ds ->+ Block ds `shouldSatisfy` cleanBy cleanDeclaration+++ pend++ describe "cleanCardReference" $ do+ it "works the same as cleanCardName separately" $ do+ forAll arbitrary $ \cnr ->+ cleanBy cleanCardNameReference cnr === cleanBy cleanCardReference (CardName cnr)++ it "works the same as cleanCardFile separately" $ do+ forAll arbitrary $ \cfr ->+ cleanBy cleanCardFileReference cfr === cleanBy cleanCardReference (CardFile cfr)++ pend++ describe "cleanCardNameReference" $ do+ it "reports card name references with an invalid card name" $ do+ forAll (arbitrary `suchThat` (not . cleanBy cleanCardName)) $ \cn ->+ CardNameReference cn `shouldNotSatisfy` cleanBy cleanCardNameReference++ it "doesn't report card name references with a valid card name" $ do+ forAll (arbitrary `suchThat` cleanBy cleanCardName) $ \cn ->+ CardNameReference cn `shouldSatisfy` cleanBy cleanCardNameReference++ pend++ describe "cleanCardFileReference" $ do+ it "reports card file references with an invalid filepath" $ do+ forAll (arbitrary `suchThat` (not . cleanBy cleanFilePath)) $ \fp ->+ forAll arbitrary $ \cn ->+ CardFileReference fp cn `shouldNotSatisfy` cleanBy cleanCardFileReference++ it "reports card file references with an invalid card name" $ do+ forAll arbitrary $ \fp ->+ forAll (arbitrary `suchThat` (not . cleanBy cleanCardNameReference)) $ \cn ->+ CardFileReference fp (Just cn) `shouldNotSatisfy` cleanBy cleanCardFileReference++ it "doesn't report card file references with a valid card name reference and valid filepath" $ do+ forAll (arbitrary `suchThat` cleanBy cleanFilePath) $ \fp ->+ forAll (arbitrary `suchThat` cleanBy cleanCardNameReference) $ \cn ->+ CardFileReference fp (Just cn) `shouldSatisfy` cleanBy cleanCardFileReference++ pend+++ describe "cleanFilePath" $ do+ it "reports empty an filepath" $ do+ filePathDirty []++ let nonNull = arbitrary `suchThat` (not . null)+ it "reports filepaths with newlines" $ do+ forAll (nonNull `suchThat` containsNewlineCharacter) filePathDirty++ let withoutNewlines = nonNull `suchThat` (not . containsNewlineCharacter)+ it "reports filepaths with multiple consequtive slashes" $ do+ once $ forAll (withoutNewlines `suchThat` containsMultipleConsequtiveSlashes) filePathDirty++ let c = filePathClean+ it "doesn't report these valid filepaths" $ do+ c "noextension"+ c ".bashrc"+ c "file.txt"+ c "Some file with spaces.doc"+ c "some/relative/filepath.file"+++-- TODO(syd) Use the default config to generate this!+defaultCompilerState :: CompilerState+defaultCompilerState = CompilerState+ { state_deployment_kind_override = Nothing+ , state_into = ""+ , state_outof_prefix = []+ }++singleCompileDecSpec :: Spec+singleCompileDecSpec = describe "compileDec" $ do+ let s = defaultCompilerState+ let c = defaultConfig+ let sc = singleShouldCompileTo c s++ let nonNull = arbitrary `suchThat` (not . null)+ let validFilePath = nonNull `suchThat` (not . containsNewlineCharacter)+ let easyFilePath = validFilePath `suchThat` (not . isPrefixOf ".")+ let validFp = arbitrary `suchThat` cleanBy cleanFilePath++ describe "Deploy" $ do+ it "uses the exact right text in source and destination when given valid filepaths without a leading dot" $ do+ forAll easyFilePath $ \from ->+ forAll easyFilePath $ \to ->+ sc (Deploy from to Nothing) (Put [from] to LinkDeployment)++ it "handles filepaths with a leading dot correctly" $ do+ pending++ it "figures out the correct paths in these cases with default config and initial state" $ do+ let d = (Deploy "from" "to" $ Just LinkDeployment)+ sc d (Put ["from"] "to" LinkDeployment)++ it "uses the alternates correctly" $ do+ pending++ it "uses the into's correctly" $ do+ pending++ it "uses the outof's correctly" $ do+ pending++ pend++ describe "SparkOff" $ do+ it "adds a single card file reference to the list of cards to spark later" $ do+ forAll validFilePath $ \f ->+ let cr = CardFile $ CardFileReference f Nothing+ d = SparkOff cr+ in compileSingleDec d s c `shouldBe` Right (s, ([], [cr]))++ it "adds any card reference to the list" $ do+ pending++ pend++ let shouldState = shouldResultInState c s+ describe "IntoDir" $ do+ it "adds the given directory to the into state" $ do+ forAll validFp $ \fp ->+ shouldState (IntoDir fp) $ s { state_into = fp }++ it "compounds with the input state" $ do+ pendingWith "Change the input state to an explicit list first"++ pend++ describe "OutofDir" $ do+ it "adds the given directory to the outof state" $ do+ forAll validFp $ \fp ->+ shouldState (OutofDir fp) $ s { state_outof_prefix = [Literal fp] }++ pend++ describe "DeployKindOverride" $ do+ it "modifies the internal deployment kind override" $ do+ property $ \kind -> shouldState (DeployKindOverride kind) $ s { state_deployment_kind_override = Just kind }++ pend++ describe "Block" $ do+ it "uses a separate scope for its sub-compilation" $ do+ property $ \ds -> shouldState (Block ds) s++ pend++ describe "Alternatives" $ do+ it "adds an alternatives prefix to the outof prefix in the compiler state" $ do+ forAll (listOf validFilePath) $ \fps ->+ shouldState (Alternatives fps) $ s { state_outof_prefix = [Alts fps] }++ pend++runDefaultSparker :: Sparker a -> IO (Either SparkError a)+runDefaultSparker func = flip runReaderT defaultConfig $ runExceptT $ func++hopTests :: Spec+hopTests = do+ describe "hop test" $ do+ let dir = "test_resources/hop_test"+ let root = dir </> "root.sus"+ let hop1 = dir </> "hop1dir" </> "hop1.sus"+ let hop2 = dir </> "hop1dir" </> "hop2dir" </> "hop2.sus"+ let hop3 = dir </> "hop1dir" </> "hop2dir" </> "hop3dir" </> "hop3.sus"+ it "compiles hop3 correctly" $ do+ r <- runDefaultSparker $ compileJob $ CardFileReference hop3 Nothing+ r `shouldBe` Right [Put ["z/delta"] "d/three" LinkDeployment]++ it "compiles hop2 correctly" $ do+ r <- runDefaultSparker $ compileJob $ CardFileReference hop2 Nothing+ r `shouldBe` Right+ [ Put ["y/gamma"] "c/two" LinkDeployment+ , Put ["hop3dir/z/delta"] "d/three" LinkDeployment+ ]++ it "compiles hop1 correctly" $ do+ r <- runDefaultSparker $ compileJob $ CardFileReference hop1 Nothing+ r `shouldBe` Right+ [ Put ["x/beta"] "b/one" LinkDeployment+ , Put ["hop2dir/y/gamma"] "c/two" LinkDeployment+ , Put ["hop2dir/hop3dir/z/delta"] "d/three" LinkDeployment+ ]++ it "compiles root correctly" $ do+ r <- runDefaultSparker $ compileJob $ CardFileReference root Nothing+ r `shouldBe` Right+ [ Put ["u/alpha"] "a/zero" LinkDeployment+ , Put ["hop1dir/x/beta"] "b/one" LinkDeployment+ , Put ["hop1dir/hop2dir/y/gamma"] "c/two" LinkDeployment+ , Put ["hop1dir/hop2dir/hop3dir/z/delta"] "d/three" LinkDeployment+ ]++exactTests :: Spec+exactTests = do+ let runJsonSparker :: Sparker a -> IO (Either SparkError a)+ runJsonSparker func = flip runReaderT (defaultConfig {conf_compile_format = FormatJson}) $ runExceptT func++ describe "exact tests" $ do+ let dir = "test_resources/exact_compile_test_src"+ forFileInDirss [dir] $ \fp ->+ if takeExtension fp == ".res"+ then return ()+ else do+ it fp $ do+ let orig = fp+ let result = fp <.> "res"+ ads <- runDefaultSparker $ compileJob $ CardFileReference orig Nothing+ eds <- runJsonSparker $ inputCompiled result+ ads `shouldBe` eds++++compilerBlackBoxTests :: Spec+compilerBlackBoxTests = do+ let tr = "test_resources"+ describe "Correct succesful compile examples" $ do+ let dirs = map (tr </>) ["shouldCompile", "hop_test"]+ forFileInDirss dirs $ \f -> do+ it f $ do+ r <- runDefaultSparker $ compileJob $ CardFileReference f Nothing+ r `shouldSatisfy` isRight++ describe "Correct unsuccesfull compile examples" $ do+ let dirs = map (tr </>) ["shouldNotParse", "shouldNotCompile"]+ forFileInDirss dirs $ \f -> do+ it f $ do+ r <- runDefaultSparker $ compileJob $ CardFileReference f Nothing+ r `shouldSatisfy` isLeft+
+ test/DeployerSpec.hs view
@@ -0,0 +1,263 @@+module DeployerSpec where++import Check.Internal+import Check.Types+import Config+import Config.Types+import Data.Either (isLeft)+import Data.Maybe (isNothing)+import Deployer.Internal+import Deployer.Types+import Monad+import Parser.Gen+import System.Directory hiding (createDirectoryIfMissing)+import System.FilePath.Posix ((</>))+import System.Posix.Files+import Test.Hspec+import Test.QuickCheck+import Utils++spec :: Spec+spec = do+ cleanSpec+ deploymentSpec+ completionSpec++cleanSpec :: Spec+cleanSpec = do+ let sandbox = "test_sandbox"+ let setup = createDirectoryIfMissing sandbox+ let teardown = removeDirectoryRecursive sandbox++ let clean :: SparkConfig -> CleanupInstruction -> IO ()+ clean conf ci = runSparker conf (performClean ci) `shouldReturn` Right ()++ beforeAll_ setup $ afterAll_ teardown $ do+ describe "performClean" $ do++ it "doesn't remove this file if that's not in the config" $ do+ let c = defaultConfig { conf_deploy_replace_files = False }+ withCurrentDirectory sandbox $ do+ let file = "test.txt"+ writeFile file "This is a test"+ diagnoseFp file `shouldReturn` IsFile+ clean c $ CleanFile file+ diagnoseFp file `shouldReturn` IsFile+ removeFile file+ diagnoseFp file `shouldReturn` Nonexistent++ it "removes this file if that's in the config" $ do+ let c = defaultConfig { conf_deploy_replace_files = True }+ withCurrentDirectory sandbox $ do+ let file = "test.txt"+ writeFile file "This is a test"+ diagnoseFp file `shouldReturn` IsFile+ clean c $ CleanFile file+ diagnoseFp file `shouldReturn` Nonexistent++ it "doesn't remove this directory if that's not in the config" $ do+ let c = defaultConfig { conf_deploy_replace_directories = False }+ withCurrentDirectory sandbox $ do+ let dir = "testdirectory"+ createDirectoryIfMissing dir+ diagnoseFp dir `shouldReturn` IsDirectory+ clean c $ CleanDirectory dir+ diagnoseFp dir `shouldReturn` IsDirectory+ removeDirectoryRecursive dir+ diagnoseFp dir `shouldReturn` Nonexistent++ it "removes this directory if that's in the config" $ do+ let c = defaultConfig { conf_deploy_replace_directories = True }+ withCurrentDirectory sandbox $ do+ let dir = "testdirectory"+ createDirectoryIfMissing dir+ diagnoseFp dir `shouldReturn` IsDirectory+ clean c $ CleanDirectory dir+ diagnoseFp dir `shouldReturn` Nonexistent++ it "doesn't remove this link if that's not in the config" $ do+ let c = defaultConfig { conf_deploy_replace_links = False }+ withCurrentDirectory sandbox $ do+ let link = "testlink"+ let file = "testfile"+ writeFile file "This is a test"+ createSymbolicLink file link+ diagnoseFp link `shouldReturn` IsLinkTo file+ clean c $ CleanLink link+ diagnoseFp link `shouldReturn` IsLinkTo file+ removeLink link+ diagnoseFp link `shouldReturn` Nonexistent+ removeFile file+ diagnoseFp file `shouldReturn` Nonexistent++ it "removes this link with an existent source if that's in the config" $ do+ let c = defaultConfig { conf_deploy_replace_links = True }+ withCurrentDirectory sandbox $ do+ let link = "testlink"+ let file = "testfile"+ writeFile file "This is a test"+ createSymbolicLink file link+ diagnoseFp link `shouldReturn` IsLinkTo file+ clean c $ CleanLink link+ diagnoseFp link `shouldReturn` Nonexistent+ removeFile file+ diagnoseFp file `shouldReturn` Nonexistent++ it "removes this link with a nonexistent source if that's in the config" $ do+ let c = defaultConfig { conf_deploy_replace_links = True }+ withCurrentDirectory sandbox $ do+ let link = "testlink"+ let file = "testfile"+ createSymbolicLink file link+ diagnoseFp link `shouldReturn` IsLinkTo file+ diagnoseFp file `shouldReturn` Nonexistent+ clean c $ CleanLink link+ diagnoseFp link `shouldReturn` Nonexistent+ diagnoseFp file `shouldReturn` Nonexistent++deploymentSpec :: Spec+deploymentSpec = do+ let sandbox = "test_sandbox"+ let setup = createDirectoryIfMissing sandbox+ let teardown = removeDirectoryRecursive sandbox++ beforeAll_ setup $ afterAll_ teardown $ do+ describe "copy" $ do+ it "succcesfully copies this file" $ do+ withCurrentDirectory sandbox $ do+ let src = "testfile"+ let dst = "testcopy"+ writeFile src "This is a file."++ diagnoseFp src `shouldReturn` IsFile+ diagnoseFp dst `shouldReturn` Nonexistent++ -- Under test+ copy src dst++ diagnoseFp src `shouldReturn` IsFile+ diagnoseFp dst `shouldReturn` IsFile++ dsrc <- diagnose src+ ddst <- diagnose dst+ diagnosedHashDigest ddst `shouldBe` diagnosedHashDigest dsrc++ removeFile src+ removeFile dst++ diagnoseFp src `shouldReturn` Nonexistent+ diagnoseFp dst `shouldReturn` Nonexistent++ it "succcesfully copies this directory" $ do+ withCurrentDirectory sandbox $ do+ let src = "testdir"+ let dst = "testcopy"+ createDirectoryIfMissing src++ diagnoseFp src `shouldReturn` IsDirectory+ diagnoseFp dst `shouldReturn` Nonexistent++ -- Under test+ copy src dst++ diagnoseFp src `shouldReturn` IsDirectory+ diagnoseFp dst `shouldReturn` IsDirectory++ dsrc <- diagnose src+ ddst <- diagnose dst+ diagnosedHashDigest ddst `shouldBe` diagnosedHashDigest dsrc++ removeDirectoryRecursive src+ removeDirectoryRecursive dst++ diagnoseFp src `shouldReturn` Nonexistent+ diagnoseFp dst `shouldReturn` Nonexistent++ describe "link" $ do+ it "successfully links this file" $ do+ withCurrentDirectory sandbox $ do+ let src = "testfile"+ let dst = "testlink"++ diagnoseFp src `shouldReturn` Nonexistent+ diagnoseFp dst `shouldReturn` Nonexistent++ writeFile src "This is a test."++ diagnoseFp src `shouldReturn` IsFile+ diagnoseFp dst `shouldReturn` Nonexistent++ -- Under test+ link src dst++ diagnoseFp src `shouldReturn` IsFile+ diagnoseFp dst `shouldReturn` IsLinkTo src++ removeFile src+ removeLink dst++ diagnoseFp src `shouldReturn` Nonexistent+ diagnoseFp dst `shouldReturn` Nonexistent++ it "successfully links this directory" $ do+ withCurrentDirectory sandbox $ do+ let src = "testdir"+ let dst = "testlink"++ diagnoseFp src `shouldReturn` Nonexistent+ diagnoseFp dst `shouldReturn` Nonexistent++ createDirectoryIfMissing src++ diagnoseFp src `shouldReturn` IsDirectory+ diagnoseFp dst `shouldReturn` Nonexistent++ -- Under test+ link src dst++ diagnoseFp src `shouldReturn` IsDirectory+ diagnoseFp dst `shouldReturn` IsLinkTo src++ removeDirectoryRecursive src+ removeLink dst++ diagnoseFp src `shouldReturn` Nonexistent+ diagnoseFp dst `shouldReturn` Nonexistent+++completionSpec :: Spec+completionSpec = do+ describe "complete" $ do+ -- Necessary because not all utilities can handle paths with '~' in them.+ it "replaces the home directory as specified for simple home directories and simple paths" $ do+ forAll arbitrary $ \env ->+ forAll generateWord $ \home ->+ forAll generateWord $ \fp ->+ complete home env ("~" </> fp) `shouldBe` Right (home </> fp)++ describe "parseId" $ do+ it "Works for these cases" $ do+ parseId "" `shouldBe` []+ parseId "file" `shouldBe` [Plain "file"]+ parseId "something$(with)variable" `shouldBe` [Plain "something", Var "with", Plain "variable"]+ parseId "$(one)$(two)$(three)" `shouldBe` [Var "one", Var "two", Var "three"]++ describe "replaceId" $ do+ it "leaves plain ID's unchanged in any environment" $ do+ forAll arbitrary $ \env ->+ forAll arbitrary $ \s ->+ replaceId env (Plain s) `shouldBe` Right s++ it "returns Left if a variable is not in the environment" $ do+ forAll arbitrary $ \var ->+ forAll (arbitrary `suchThat` (isNothing . lookup var)) $ \env ->+ replaceId env (Var var) `shouldSatisfy` isLeft++ it "replaces a variable if it's in the environment" $ do+ forAll arbitrary $ \var ->+ forAll arbitrary $ \val ->+ forAll (arbitrary `suchThat` (isNothing . lookup var)) $ \env1 ->+ forAll (arbitrary `suchThat` (isNothing . lookup var)) $ \env2 ->+ replaceId (env1 ++ [(var, val)] ++ env2) (Var var) `shouldBe` Right val++
+ test/EndToEndSpec.hs view
@@ -0,0 +1,71 @@+module EndToEndSpec (spec) where++import Spark+import System.Directory hiding (createDirectoryIfMissing)+import System.Environment (withArgs)+import System.FilePath.Posix ((</>))+import System.Posix.Files+import Test.Hspec+import Utils++spec :: Spec+spec = do+ let sandbox = "test_sandbox"+ let setup = createDirectoryIfMissing sandbox+ let teardown = removeDirectoryRecursive sandbox++ let rsc = "test_resources" </> "end-to-end"++ beforeAll_ setup $ afterAll_ teardown $ do+ describe "standard bash card test" $ do+ let bashrsc = rsc </> "bash.sus"+ let bashrscres = rsc </> "bash.sus.res"+ let cardfile = sandbox </> "bash.sus"++ let up = do+ copyFile bashrsc cardfile+ withCurrentDirectory sandbox $ do+ createDirectoryIfMissing "bash"+ withCurrentDirectory "bash" $ do+ writeFile "bash_aliases" "bash_aliases"+ writeFile "bashrc" "bashrc"+ writeFile "bash_profile" "bash_profile"++ let down = do+ removeFile cardfile+ withCurrentDirectory sandbox $ do+ removeDirectoryRecursive "bash"+++ beforeAll_ up $ afterAll_ down $ do+ it "parses correcty" $ do+ withArgs ["parse", cardfile] spark `shouldReturn` ()++ it "compiles correctly" $ do+ let outfile = sandbox </> "bash.sus.res"++ withArgs ["compile", cardfile, "--output", outfile] spark `shouldReturn` ()++ actual <- readFile outfile+ expected <- readFile bashrscres+ actual `shouldBe` expected++ it "checks without exceptions" $ do+ withArgs ["check", cardfile] spark `shouldReturn` ()++ it "deploys correctly" $ do+ withArgs ["deploy", cardfile] spark `shouldReturn` ()++ let f1 = "subdir" </> ".bashrc"+ f2 = "subdir" </> ".bash_aliases"+ f3 = "subdir" </> ".bash_profile"++ readFile f1 `shouldReturn` "bashrc"+ readFile f2 `shouldReturn` "bash_aliases"+ readFile f3 `shouldReturn` "bash_profile"++ removeLink f1+ removeLink f2+ removeLink f3++
+ test/MainTest.hs view
@@ -0,0 +1,11 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}+module MainTest where++import qualified Spec+import Test.Hspec.Formatters+import Test.Hspec.Runner++main :: IO ()+main = hspecWith defaultConfig {configFormatter = Just progress} Spec.spec++
− test/Parser/Test.hs
@@ -1,388 +0,0 @@-{-# OPTIONS_GHC -F -pgmF htfpp #-}-module Parser.Test (htf_thisModulesTests) where--import Control.Applicative-import Test.Framework-import Test.HUnit (Assertion)-import Text.ParserCombinators.Parsec--import Parser-import Types---testFileName = "parser testinput"----[ Parser helper functions ]-----parserTest :: (Show a, Eq a) => Parser a -> a -> String -> Assertion-parserTest p result str = assertEqual (Right result) parseResult- where parseResult = parse p testFileName str--parserTests :: (Show a, Eq a) => Parser a -> [(a, [String])] -> Assertion-parserTests p tests = sequence_ $ map (\(result, strs) -> sequence_ $ map (\s -> assertEqual (Right result) (parseResult s)) strs) tests- where parseResult = parse p testFileName--parseItself :: Parser String -> String -> Assertion-parseItself p str = parserTest p str str--parseSuccess :: Parser String -> String -> Assertion-parseSuccess p str = (assertRight $ parse (p <* eof) testFileName str) >> return ()--parseFail :: Parser String -> String -> Assertion-parseFail p str = (assertLeft $ parse (p <* eof) testFileName str) >> return ()--parseItselfs :: Parser String -> [String] -> Assertion-parseItselfs p strs = sequence_ $ map (parseItself p) strs--parseSuccesses :: Parser String -> [String] -> Assertion-parseSuccesses p strs = sequence_ $ map (parseSuccess p) strs--parseFails :: Parser String -> [String] -> Assertion-parseFails p strs = sequence_ $ map (parseFail p) strs-------[ Language ]----test_card_empty = parserTests card $- [- (Card "" testFileName (Block []), [- "card \"\" {}"- ]- )- , (Card "hi" testFileName (Block []), [- "card hi {}"- , "card \"hi\" {}"- , "card \nhi\n{}"- ]- )- , (Card "something spaced" testFileName (Block []), [- "card \"something spaced\" {}"- , " card \"something spaced\" {\n}"- , " \t \n card \n\r \"something spaced\" \t\n{\n\r}"- ]- )- ]--test_card_complicated = parserTests card $- [- (myCard,- [- "card testcard {\n alternatives $(HOST) shared\n hello l-> goodbye\n into $(HOME)\n outof depot\n spark card othercard\n kind link\n {\n one c-> more\n source -> destination\n file\n }\n}"- ]- )- ]- where- myCard = Card "testcard" testFileName $ Block- [- Alternatives ["$(HOST)", "shared"]- , Deploy "hello" "goodbye" (Just LinkDeployment)- , IntoDir "$(HOME)"- , OutofDir "depot"- , SparkOff (CardName (CardNameReference "othercard"))- , DeployKindOverride LinkDeployment- , Block [- Deploy "one" "more" (Just CopyDeployment)- , Deploy "source" "destination" Nothing- , Deploy "file" "file" Nothing- ]- ]---test_Block = parserTests block $- [- (Block [IntoDir "~", Deploy "bashrc" ".bashrc" Nothing],- [- "{into ~;bashrc -> .bashrc}"- , "{into ~ ; \tbashrc -> .bashrc;}"- , "{ into ~\n\tbashrc -> .bashrc}"- , "{\n\tinto \"~\"\nbashrc -> .bashrc}"- , "{\n into ~\n bashrc -> .bashrc\n}"- , "{\n into \"~\"\n \"bashrc\" -> \".bashrc\"\n}"- ]- )- ]--test_sparkOff = parserTests sparkOff $- [- (SparkOff (CardName $ CardNameReference "name"),- [- "spark card name"- , "sparkcard \"name\""- , "spark\tcard\tname"- , "spark \tcard\t \tname"- ]- )- ]--test_cardNameReference = parserTests cardNameReference $- [- (CardNameReference "name",- [- "card name"- , "card \"name\""- , "card\tname"- , "card\t \tname"- ]- )- ]--test_cardFileReference = parserTests cardFileReference $- [- (CardFileReference "card.sus" Nothing,- [- "file card.sus"- , "file \"card.sus\""- , "file\tcard.sus"- , "file \t card.sus"- ]- )- , (CardFileReference "card.sus" (Just $ CardNameReference "name"),- [- "file card.sus name"- , "file \"card.sus\" \"name\""- , "file\tcard.sus\tname"- , "file \t card.sus \t name"- ]- )- ]--test_intoDir = parserTests intoDir $- [- (IntoDir "~", [- "into ~"- , "into \t ~"- , "into\t \t ~"- , "into \"~\""- ]- )- , (IntoDir "~/.xmonad", [- "into ~/.xmonad"- , "into \"~/.xmonad\""- , "into ~/.xmonad/"- ]- )- ]--test_outofDir = parserTests outOfDir $- [- (OutofDir "bash", [- "outof bash"- , "outof \t bash"- , "outof \"bash\""- , "outof bash"- ]- )- , (OutofDir "xmonad", [- "outof xmonad"- , "outof \t\t\txmonad"- , "outof \"xmonad\""- , "outof \txmonad"- ]- )- ]--test_deployment = parserTests deployment $- [- (Deploy "bashrc" "/home/user/.bashrc" Nothing, [- "bashrc -> /home/user/.bashrc"- , "bashrc \t-> /home/user/.bashrc"- , "bashrc ->\"/home/user/.bashrc\""- , "\"bashrc\"-> /home/user/.bashrc"- , "\"bashrc\" -> \"/home/user/.bashrc\""- , "\"bashrc\"->\"/home/user/.bashrc\""- ]- )- , (Deploy "xmonad.hs" "/home/user/.xmonad/xmonad.hs" (Just LinkDeployment), [- "xmonad.hs l-> /home/user/.xmonad/xmonad.hs"- , "\"xmonad.hs\"l-> /home/user/.xmonad/xmonad.hs"- ]- )- , (Deploy "something with spaces" "/home/user/test.txt" (Just CopyDeployment), [- "\"something with spaces\"c->/home/user/test.txt"- , "\"something with spaces\"\tc->/home/user/test.txt"- ]- )- , (Deploy "file.txt" "file.txt" Nothing, [- "file.txt"- , "\"file.txt\""- ]- )- ]--test_deploymentKind_link = parserTest deploymentKind (Just LinkDeployment) "l->"-test_deploymentKind_copy = parserTest deploymentKind (Just CopyDeployment) "c->"-test_deploymentKind_default = parserTest deploymentKind Nothing "->"--test_directory = parseItselfs directory $- [- "~"- , "~/.vim"- , "~/Dropbox"-- , "/home/user"- , "/home/user/.xmonad"- ]--test_filepath = parseItselfs filepath $- [- "withoutExtension"- , "test.txt"- , "file.somelongextension"-- , "/home/user/test.txt"- , "/home/user/test.multiple.extensions"-- , "/home/user/../user/test.txt"- ]--test_filepath_quoted = parserTest filepath "/home/user/long/path/with spaces" "\"/home/user/long/path/with spaces\""--test_lineComment = parseSuccesses lineComment $- [- "#hello\n", "#hello\n\r"- , "# This is a very long\tline comment\t with whitespaces \n"- ]--test_blockComment = parseSuccesses blockComment $- [- "[[ hellokidoki ]]"- , "[[ This is a very long block comment\n with \n\r whitespace\n ]]"- ]-----[ Identifiers ]----test_plainIdentifier_success = parseItselfs plainIdentifier $- [- "test"- , "thing"- , "sus-depot"- , "super_user_spark"- , "super.user.spark"- , "a", "b", "c", "d", "e", "f", "g", "h", "i", "j", "k", "l", "m", "n", "o", "p", "q", "r", "s", "t", "u", "v", "w", "x", "y", "z"- ]--test_plainIdentifier_fail = parseFails plainIdentifier $- [- "\"identifier\""- , "\"", "\n", "\r", ";", " ", "\t", "{", "}"- , "sus depot"- ]--test_quotedIdentifier_success = parseSuccesses quotedIdentifier $- [- "\"a\"", "\"abc\"", "\"abcdefghijklmnopqrstuvwxyz\""- , "\" \"", "\"\t\"", "\";\"", "\"{\"", "\"}\""- , "\"sus depot\"", "\"sus\tdepot\""- ]--test_quotedIdentifier_fail = parseFails quotedIdentifier $- [- "\""- , "\n", "\r", ";", " ", "\t", "{", "}"- , "\"\n\"", "\"\r\"", " ", "\t", "{", "}"- , "\"a", "\"abc"- , "a\"", "abc\""- ]------[ Delimiters ]----test_inBraces_letter = parserTest (inBraces plainIdentifier) "a" "{a}"-test_inBraces_word = parserTest (inBraces plainIdentifier) "abc" "{abc}"--test_inQuotes_letter = parserTest (inQuotes plainIdentifier) "a" "\"a\""-test_inQuotes_word = parserTest (inQuotes plainIdentifier) "abc" "\"abc\""---test_delim = parseItselfs delim $- [- ";"- , "\n"- , "\r"- , "\n\r"- , "\r\n"- , "\n\r \t \n\t \n"- ]-----[ Whitespace ]----test_inLineSpace = parserTests (inLineSpace plainIdentifier) $- [- ("a", [- "a"- , " a \t "- , " a "- , "\ta\t"- ]- )- , ("abc", [- "abc"- , " abc "- , "abc"- , "abc\t\t\t\t"- ]- )- ]--test_inWhiteSpace = parserTests (inWhiteSpace plainIdentifier) $- [- ("a", [- "a"- , " \n\r a \t "- , " a\n "- , "\ta\r\t"- ]- )- , ("abc", [- "abc"- , " abc "- , "abc\t\t\t\t"- ]- )- ]--test_linespace = parseItselfs linespace $- [- ""- , " "- , "\t"- , " \t"- , "\t "- , "\t \t\t\t \t\t \t"- ]--test_whitespace = parseItselfs whitespace $- [- ""- , " "- , "\t"- , "\n"- , "\r"- , " \t"- , "\n\r"- , " \t\n\r"- , " \t \n \r\n\t\t\t \n\n\r\n"- ]--test_eol = parseItselfs eol $- [- "\n\r"- , "\r\n"- , "\n"- , "\r"- ]--test_eol_fail = parseFails eol $- [- ""- , " "- , "\t"- , "\t "- , " \t"- ]-
+ test/ParserSpec.hs view
@@ -0,0 +1,498 @@+module ParserSpec where++import CoreTypes+import Data.Either (isLeft, isRight)+import Data.List (intercalate)+import Language.Types+import Parser.Gen+import Parser.Internal+import Parser.TestUtils+import System.FilePath.Posix ((</>))+import Test.Hspec+import Test.QuickCheck+import TestUtils+import Text.Parsec++spec :: Spec+spec = parallel $ do+ blankspaceParserTests+ enclosingCharacterTests+ delimiterTests+ identifierParserTests+ commentParserTests+ pathParserTests+ declarationParserTests+ parserBlackBoxTests+++enclosingCharacterTests :: Spec+enclosingCharacterTests = do+ describe "inBraces" $ do+ it "succeeds for cases where we enclose braces around a string without braces" $ do+ forAll (listOf1 arbitrary `suchThat` (\c -> c /= "{" && c /= "}")) (\word ->+ parseShouldSucceedAs (inBraces $ string word) ("{" ++ word ++ "}") word)++ describe "inQuotes" $ do+ it "succeeds for cases where we enclose quotes around a string without quotes" $ do+ forAll (listOf1 arbitrary `suchThat` (/= "\"")) (\word ->+ parseShouldSucceedAs (inQuotes $ string word) ("\"" ++ word ++ "\"") word)++blankspaceParserTests :: Spec+blankspaceParserTests = do+ describe "eol" $ do+ let s = shouldSucceed eol+ it "succeeds for Linux line endings" $ do+ s "\n"+ it "succeeds for Windows line endings" $ do+ s "\r\n"+ it "succeeds for Mac line endings" $ do+ s "\r"+ let f = shouldFail eol+ it "fails for the empty string" $ do+ f ""+ it "fails for spaces" $ do+ forAll (listOf generateSpace) (\ss -> f ss)+ it "fails for tabs" $ do+ forAll (listOf generateTab) (\ss -> f ss)+ it "fails for linespace" $ do+ forAll generateLineSpace (\ls -> f ls)++ describe "linespace" $ do+ let s = shouldSucceed linespace+ it "succeeds for spaces" $ do+ forAll (listOf generateSpace) s+ it "succeeds for tabs" $ do+ forAll (listOf generateTab) s+ it "succeeds for mixtures of spaces and tabs" $ do+ forAll generateLineSpace s++ let f = shouldSucceed whitespace+ it "fails for line ending characters" $ do+ forAll (listOf $ oneof [generateCarriageReturn, generateLineFeed]) f+ it "fails for any non-linespace, even if there's linespace in it" $ do+ forAll (listOf1 generateNormalCharacter) (\ls ->+ forAll generateLineSpace (\ls1 ->+ forAll generateLineSpace (\ls2 ->+ shouldFail linespace (ls1 ++ ls ++ ls2))))+++ describe "whitespace" $ do+ let s = shouldSucceed whitespace+ it "succeeds for spaces" $ do+ forAll (listOf generateSpace) s+ it "succeeds for tabs" $ do+ forAll (listOf generateTab) s+ it "succeeds carriage returns" $ do+ forAll (listOf generateCarriageReturn) s+ it "succeeds line feeds" $ do+ forAll (listOf generateLineFeed) s+ it "succeeds for mixtures of spaces, tabs, carriage returns and line feeds" $ do+ forAll generateWhiteSpace s++ it "fails for any non-whitespace, even if there's whitespace in it" $ do+ forAll (listOf1 generateNormalCharacter) (\ls ->+ forAll generateWhiteSpace (\ws1 ->+ forAll generateWhiteSpace (\ws2 ->+ shouldFail whitespace (ws1 ++ ls ++ ws2))))+++ describe "inLineSpace" $ do+ it "succeeds for cases where we append whitespace to the front and back of non-whitespace" $ do+ forAll generateLineSpace (\ws1 ->+ forAll generateLineSpace (\ws2 ->+ forAll (listOf1 generateNormalCharacter) (\ls ->+ parseShouldSucceedAs (inLineSpace $ string ls) (ws1 ++ ls ++ ws2) ls)))++ describe "inWhiteSpace" $ do+ it "succeeds for cases where we append whitespace to the front and back of non-whitespace" $ do+ forAll generateWhiteSpace (\ws1 ->+ forAll generateWhiteSpace (\ws2 ->+ forAll (listOf1 generateNormalCharacter) (\ls ->+ parseShouldSucceedAs (inWhiteSpace $ string ls) (ws1 ++ ls ++ ws2) ls)))++delimiterTests :: Spec+delimiterTests = do+ describe "delim" $ do+ it "succeeds on a semicolon" $ do+ shouldSucceed delim ";"+ it "succeeds on an eol" $ do+ once $ forAll (arbitrary `suchThat` succeeds eol) (shouldSucceed delim)++identifierParserTests :: Spec+identifierParserTests = do+ describe "plainIdentifier" $ do+ it "succeeds for generated plain identifiers" $ do+ forAll generatePlainIdentifier $ \(e, a) ->+ parseShouldSucceedAs plainIdentifier e a++ let pi = shouldSucceed plainIdentifier+ it "succeeds for these examples" $ do+ pi "bash"+ pi "card"+ pi ".bashrc"+ pi "xmonad.hs"++ it "fails for generated quoted identifiers" $ do+ forAll generateQuotedIdentifier $ \(e, _) ->+ shouldFail plainIdentifier e++ describe "quotedIdentifier" $ do+ it "succeeds for generated plain identifiers surrounded in quotes" $ do+ forAll generatePlainIdentifier $ \(e, a) ->+ parseShouldSucceedAs quotedIdentifier ("\"" ++ e ++ "\"") a+ it "succeeds for generated quoted identifiers" $ do+ forAll generateQuotedIdentifier $ \(e, a) ->+ parseShouldSucceedAs quotedIdentifier e a++ let pi i = parseShouldSucceedAs quotedIdentifier ("\"" ++ i ++ "\"") i+ it "succeeds for these examples" $ do+ pi "bashrc"+ pi "with spaces"++ it "fails for generated plain identifiers" $ do+ forAll generatePlainIdentifier $ \(e, _) ->+ shouldFail quotedIdentifier e++ it "fails for generated identifiers with just one quote" $ do+ forAll generatePlainIdentifier $ \(e, _) ->+ shouldFail quotedIdentifier ("\"" ++ e) .&&. shouldFail quotedIdentifier (e ++ "\"")++ describe "identifier" $ do+ it "succeeds for generated identifiers" $ do+ forAll generateIdentifier $ \(e, a) ->+ parseShouldSucceedAs identifier e a++commentParserTests :: Spec+commentParserTests = do+ describe "eatComments" $ do+ it "should succeed unchanged on anything without comments" $ do+ property $ \s -> (not $ succeedsAnywhere comment s) ==> parseShouldSucceedAs eatComments s s++ let (-=>) e a = parseShouldSucceedAs eatComments e a+ it "successfully removes comments in these strings" $ do+ "abc#def\nghi" -=> "abcghi"+ "abc# This is a bigger comment \r\nghi" -=> "abcghi"+ "abc[[def]]ghi" -=> "abcghi"+ "abc[[ This is a bigger comment ]]ghi" -=> "abcghi"+ "Heavy[[use]]of#comments\n." -=> "Heavyof."++ describe "notComment" $ do+ it "should succeed for any string that doesn't contain comments" $ do+ property $ \s -> (not $ succeedsAnywhere comment s) ==> parseShouldSucceedAs notComment s s++ describe "lineComment" $ do+ it "succeeds for generated line comments" $ do+ forAll generateLineComment $ \(e, a) -> parseShouldSucceedAs lineComment e a+ it "succeeds for these test cases" $ do+ parseShouldSucceedAs lineComment "#a\n" "a"+ parseShouldSucceedAs lineComment "# This is a comment\n" " This is a comment"+ parseShouldSucceedAs lineComment "## This is a comment with two comment signs.\n" "# This is a comment with two comment signs."+ parseShouldSucceedAs lineComment "# with other eol\r\n" " with other eol"++ describe "blockComment" $ do+ it "succeeds for generated block comments" $ do+ forAll generateBlockComment $ \(e, a) -> parseShouldSucceedAs blockComment e a+ it "succeeds of these test cases" $ do+ parseShouldSucceedAs blockComment "[[a]]" "a"+ parseShouldSucceedAs blockComment "[[ This is a block comment. ]]" " This is a block comment. "+ parseShouldSucceedAs blockComment "[[ [This is a [block] comment containing brackets.] ]]" " [This is a [block] comment containing brackets.] "++ describe "comment" $ do+ it "succeeds for generated line comments" $ do+ forAll generateLineComment $ \(e, a) -> parseShouldSucceedAs comment e a++ it "succeeds for generated block comments" $ do+ forAll generateBlockComment $ \(e, a) -> parseShouldSucceedAs comment e a++pathParserTests :: Spec+pathParserTests = do+ describe "filepath" $ do+ it "succeeds for generated filepaths" $ do+ forAll generateFilePath $ \(e, a) -> parseShouldSucceedAs filepath e a+ it "succeeds for this quoted filepath with a space in it" $ do+ parseShouldSucceedAs filepath "\"/home/user/with spaces\"" "/home/user/with spaces"++ let s = shouldSucceed filepath+ it "succeeds for this file without an extension" $ do+ s "withoutExtension"+ it "succeeds for this simple file" $ do+ s "test.txt"+ it "succeeds for this simple file with a long extension" $ do+ s "file.somelongextension"+ it "succeeds for this absolute filepath" $ do+ s "/home/user/test.txt"+ it "succeeds for this absolute filepath with a long extension" $ do+ s "/home/user/file.somelongextension"+ it "succeeds for this absolute filepath with multiple extensions" $ do+ s "/home/user/test.multiple.extensions"+ it "succeeds for this relative filepath with a double dot" $ do+ s "/home/user/../user/test.txt"++ let f = shouldFail filepath+ it "fails for just a slash" $ do+ f "/"+ it "fails for strings ending in a slash" $ do+ property $ \s -> f (s ++ "/")++ describe "directory" $ do+ it "succeeds for generated directories" $ do+ forAll generateDirectory $ \(e, a) -> parseShouldSucceedAs directory e a++ let s = shouldSucceed directory+ it "succeeds for the home directory" $ do+ s "~"+ it "succeeds for this relative directory" $ do+ s "directory"+ it "succeeds for this absolute directory" $ do+ s "/home/user"+ it "succeeds for these directories in the home directory" $ do+ s "~/.vim"+ s "~/Dropbox"+ s "~/.xmonad"++ let f = shouldFail directory+ it "fails for just a slash" $ do+ f "/"+ it "fails for strings ending in a slash" $ do+ property $ \s -> f (s ++ "/")+++declarationParserTests :: Spec+declarationParserTests = do+ describe "cardName" $ do+ it "succeeds on every card name that we generate" $ do+ forAll generateCardName $ \(a, e) -> parseShouldSucceedAs cardNameP a e++ describe "card" $ do+ let pc = parseShouldSucceedAs card+ it "succeeds on this card with an empty name correctly" $ do+ pc "card \"\" {}" $ Card "" (Block [])++ it "succeeds on this compressed empty cards" $ do+ forAll generateCardName $ \(a, e) ->+ parseShouldSucceedAs card ("card" ++ a ++ "{}") $ Card e (Block [])++ it "succeeds on empty cards with whitespace around the name" $ do+ forAll generateCardName $ \(a, e) ->+ forAll (twice generateWhiteSpace) $ \(ws1, ws2) ->+ parseShouldSucceedAs card ("card" ++ ws1 ++ a ++ ws2 ++ "{}") $ Card e (Block [])++ it "succeeds on empty cards with whitespace between the brackets" $ do+ forAll generateCardName $ \(a, e) ->+ forAll generateWhiteSpace $ \ws ->+ parseShouldSucceedAs card ("card" ++ a ++ "{" ++ ws ++ "}") $ Card e (Block [])++ it "fails on any card with an empty body" $ do+ forAll generateCardName $ \(a, _) ->+ forAll generateWhiteSpace $ \ws ->+ shouldFail card ("card" ++ a ++ ws)++ it "succeeds on this complicated example" $ do+ parseShouldSucceedAs card ("card complicated {\n alternatives $(HOST) shared\n hello l-> goodbye\n into $(HOME)\n outof depot\n spark card othercard\n kind link\n {\n one c-> more\n source -> destination\n file\n }\n}")+ $ Card "complicated" $ Block+ [+ Alternatives ["$(HOST)", "shared"]+ , Deploy "hello" "goodbye" (Just LinkDeployment)+ , IntoDir "$(HOME)"+ , OutofDir "depot"+ , SparkOff (CardName (CardNameReference "othercard"))+ , DeployKindOverride LinkDeployment+ , Block [+ Deploy "one" "more" (Just CopyDeployment)+ , Deploy "source" "destination" Nothing+ , Deploy "file" "file" Nothing+ ]+ ]++ describe "declarations" $ do+ it "succeeds for generated declarations'" $ do+ pending+ let s = parseShouldSucceedAs declarations+ it "succeeds for these cases" $ do+ s "into dir;outof dir" [IntoDir "dir", OutofDir "dir"]++ describe "declaration" $ do+ it "succeeds for generated declarations" $ do+ pending+ let s = parseShouldSucceedAs declaration+ it "succeeds for these cases" $ do+ s "into directory" (IntoDir "directory")+ s "outof \"other directory\"" (OutofDir "other directory")+ s "{}" (Block [])+ s "{{{};{};{}}}" (Block [Block [Block [], Block [], Block[]]])+ s "\"hi i'm a file\"c->iamthedestination" (Deploy "hi i'm a file" "iamthedestination" (Just CopyDeployment))++ describe "block" $ do+ it "succeeds for empty blocks" $ do+ parseShouldSucceedAs block "{}" (Block [])+ it "succeeds for a doubly nested empty block" $ do+ parseShouldSucceedAs block "{{}}" (Block [Block []])+ it "succeeds for a triply nested empty block" $ do+ parseShouldSucceedAs block "{{{}}}" (Block [Block [Block []]])++ let s = parseShouldSucceedAs block+ it "succeeds for these cases" $ do+ s "{into ~;bashrc -> .bashrc}" (Block [IntoDir "~", Deploy "bashrc" ".bashrc" Nothing])+ s "{\n into \"~\"\n \"xmonad\" -> \".xmonad\"\n}" (Block [IntoDir "~", Deploy "xmonad" ".xmonad" Nothing])++ describe "sparkOff" $ do+ it "succeeds for generated sparkOff declarations" $ do+ pending++ let s f g = parseShouldSucceedAs sparkOff f (SparkOff $ CardName $ CardNameReference g)+ it "succeeds for these cases" $ do+ s "spark card name" "name"+ s "sparkcardname" "name"+ s "spark card \"name with spaces\"" "name with spaces"++ describe "intoDir" $ do+ it "succeeds for generated into declarations" $ do+ forAll generateLineSpace $ \ls ->+ forAll generateDirectory $ \(d, da) ->+ parseShouldSucceedAs intoDir ("into" ++ ls ++ d) (IntoDir da)++ let s f g = parseShouldSucceedAs intoDir f (IntoDir g)+ it "succeeds for these cases" $ do+ s "into \"bash\"" "bash"+ s "into\t.xmonad" ".xmonad"+ s "into ~" "~"++ describe "outOfDir" $ do+ it "succeeds for generated outof declarations" $ do+ forAll generateLineSpace $ \ls ->+ forAll generateDirectory $ \(d, da) ->+ parseShouldSucceedAs outOfDir ("outof" ++ ls ++ d) (OutofDir da)++ let s f g = parseShouldSucceedAs outOfDir f (OutofDir g)+ it "succeeds for these cases" $ do+ s "outof bash" "bash"+ s "outof\t.xmonad" ".xmonad"++ describe "alternatives" $ do+ it "succeeds for generated alternatives declarations with single spaces" $ do+ forAll (listOf1 generateDirectory) $ \ds ->+ let (des, das) = unzip ds in+ parseShouldSucceedAs alternatives ("alternatives" ++ " " ++ intercalate " " des) (Alternatives das)++ describe "deployment" $ do+ it "succeeds for short deployments"+ pending+ it "succeeds for long deployments"+ pending++ describe "shortDeployment" $ do+ it "succeeds for any filepath with an identity deployment" $ do+ property $ \f -> succeeds filepath f+ ==> parseShouldSucceedAs shortDeployment f (Deploy f f Nothing)++ it "succeeds for generated filepaths with an identity deployment" $ do+ forAll generateFilePath $ \(f,g) -> parseShouldSucceedAs shortDeployment f (Deploy g g Nothing)++ it "succeeds for any directory with an identity deployment" $ do+ property $ \f -> succeeds directory f+ ==> parseShouldSucceedAs shortDeployment f (Deploy f f Nothing)++ it "succeeds for generated directories with an identity deployment" $ do+ forAll generateDirectory $ \(f,g) -> parseShouldSucceedAs shortDeployment f (Deploy g g Nothing)++ let s f = parseShouldSucceedAs shortDeployment f (Deploy f f Nothing)+ it "succeeds as-is for these cases" $ do+ s "file.txt"+ s "xmonad.hs"+ s "/home/user/.bashrc"++ describe "longDeployment" $ do+ it "succeeds for generated long deployments with quoted identifiers" $ do+ forAll generateDeploymentKindSymbol $ \dks ->+ forAll generateLineSpace $ \ls1 ->+ forAll generateLineSpace $ \ls2 ->+ forAll generateQuotedIdentifier $ \(fp1,fp1a) ->+ forAll generateQuotedIdentifier $ \(fp2,fp2a) ->+ case parseWithoutSource deploymentKind dks of+ Left _ -> fail "There was a problem with parsing the deployment kind"+ Right dk -> parseShouldSucceedAs longDeployment (fp1 ++ ls1 ++ dks ++ ls2 ++ fp2) (Deploy fp1a fp2a dk)++ it "succeeds for single-space-separated long deployments with gerenated plain identifiers" $ do+ pendingWith "This would go wrong with plain identifiers they can end with \'l\' or \'c\'. Make sure to document this behaviour and write another test with plain identifiers."++ let s f g h i = parseShouldSucceedAs longDeployment f (Deploy g h i)+ it "succeeds for these cases" $ do+ s "\"something with spaces\"c->/home/user/test.txt"+ "something with spaces"+ "/home/user/test.txt"+ (Just CopyDeployment)+ s "\"xmonad.hs\"l-> /home/user/.xmonad/xmonad.hs"+ "xmonad.hs"+ "/home/user/.xmonad/xmonad.hs"+ (Just LinkDeployment)+ s "bashrc\t->\t/home/user/.bashrc"+ "bashrc"+ "/home/user/.bashrc"+ Nothing+++ describe "deploymentKind" $ do+ let (-=>) = parseShouldSucceedAs deploymentKind+ it "succeeds for the link deployment kind" $ do+ "l->" -=> Just LinkDeployment+ it "succeeds for the copy deployment kind" $ do+ "c->" -=> Just CopyDeployment+ it "succeeds for the default deployment kind" $ do+ "->" -=> Nothing+ it "fails for anything else" $ do+ property $ \s -> (not $ any (== s) ["l->", "c->", "->"]) ==> shouldFail deploymentKind s++cardReferenceParserTests :: Spec+cardReferenceParserTests = do+ describe "compilerCardReference" $ do+ pend++ describe "deployerCardReference" $ do+ pend++ describe "compiledCardReference" $ do+ pend++ describe "cardReference" $ do+ pend++ describe "cardNameReference" $ do+ pend+ let s f g = parseShouldSucceedAs cardNameReference f (CardNameReference g)+ it "succeeds for these cases" $ do+ s "card name" "name"+ s "cardname" "name"+ s "card \"name with spaces\"" "name with spaces"++ describe "cardFileReference" $ do+ pend+ let s = parseShouldSucceedAs cardFileReference+ it "succeeds for these cases" $ do+ s "file card.sus" (CardFileReference "card.sus" Nothing)+ s "file card.sus name" (CardFileReference "card.sus" $ Just $ CardNameReference "name")++ describe "unprefixedCardFileReference" $ do+ pend+++parserBlackBoxTests :: Spec+parserBlackBoxTests = do+ let tr = "test_resources"+ describe "Correct succesful parse examples" $ do+ let dirs = map (tr </>) ["shouldParse", "shouldCompile", "shouldNotCompile"]+ forFileInDirss dirs $ concerningContents $ \f contents -> do+ it f $ parseFromSource sparkFile f contents `shouldSatisfy` isRight++ describe "Correct unsuccesfull parse examples" $ do+ let dirs = map (tr </>) ["shouldNotParse"]+ forFileInDirss dirs $ concerningContents $ \f contents -> do+ it f $ parseFromSource sparkFile f contents `shouldSatisfy` isLeft+++toplevelParserTests :: Spec+toplevelParserTests = do+ describe "sparkFile" $ do+ pend++ describe "resetPosition" $ do+ pend
+ test/SeedSpec.hs view
@@ -0,0 +1,24 @@+module SeedSpec where++import Compiler.Gen ()+import Compiler.TestUtils+import Compiler.Types+import PreCompiler+import Seed+import System.FilePath.Posix (isAbsolute)+import Test.Hspec+import Test.QuickCheck+import TestUtils++spec :: Spec+spec = parallel $ do+ pureSeedSpec++pureSeedSpec :: Spec+pureSeedSpec = describe "seed" $ do+ it "ensures that sources are absolute if the seed is an absolute path" $ do+ once $ forAll (arbitrary `suchThat` cleanBy cleanFilePath `suchThat` isAbsolute) $ \fp ->+ forAll arbitrary $ \ds ->+ all (\d -> all (isAbsolute) $ deployment_srcs d) $ seed fp ds++ pend
− test/TestMain.hs
@@ -1,9 +0,0 @@-{-# OPTIONS_GHC -F -pgmF htfpp #-}-module Main where--import {-@ HTF_TESTS @-} Parser.Test-import {-@ HTF_TESTS @-} Compiler.Test-import Test.Framework-import Test.Framework.BlackBoxTest--main = htfMain htf_importedTests