diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -1,6 +1,6 @@ module Main (main) where -import Spark +import SuperUserSpark main :: IO () main = spark diff --git a/src/Arguments.hs b/src/Arguments.hs deleted file mode 100644 --- a/src/Arguments.hs +++ /dev/null @@ -1,144 +0,0 @@ -{-# LANGUAGE CPP #-} -module Arguments where - -#if (MIN_VERSION_base(4,9,0)) -import Data.Monoid -#endif - -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 - -transformOptions :: Options -> Either String Instructions -transformOptions (dispatch, go) = (,) <$> pure dispatch <*> configFromOptions go - -configFromOptions :: GlobalOptions -> Either String SparkConfig -configFromOptions go = Right conf - where - conf = defaultConfig - { conf_compile_output = opt_output go - , conf_compile_kind = opt_kind go - , conf_compile_override = opt_overrride go - , conf_deploy_replace_links = opt_replace_links go || opt_replace go - , conf_deploy_replace_files = opt_replace_files go || opt_replace go - , conf_deploy_replace_directories = opt_replace_directories go || opt_replace go - , conf_debug = opt_debug go - } - -getOptions :: IO Options -getOptions = do - args <- getArgs - let result = runOptionsParser args - handleParseResult result - -runOptionsParser :: [String] -> ParserResult Options -runOptionsParser strs = execParserPure prefs optionsParser strs - where - prefs = ParserPrefs - { prefMultiSuffix = "SPARK" -- metavar suffix for multiple options - , prefDisambiguate = True -- automatically disambiguate abbreviations (default: False) - , prefShowHelpOnError = True -- always show help text on parse errors (default: False) - , prefBacktrack = True -- backtrack to parent parser when a subcommand fails (default: True) - , prefColumns = 80 -- number of columns in the terminal, used to format the help page (default: 80) - } - -optionsParser :: ParserInfo Options -optionsParser = info (helper <*> parseOptions) help - where - help = fullDesc <> progDesc description - description = "Super User Spark, author: Tom Sydney Kerckhove" - -parseOptions :: Parser Options -parseOptions = (,) <$> parseCommand <*> parseGlobalOptions - -parseCommand :: Parser Dispatch -parseCommand = hsubparser $ mconcat - [ command "parse" parseParse - , command "compile" parseCompile - , command "check" parseCheck - , command "deploy" parseDeploy - ] - -parseParse :: ParserInfo Dispatch -parseParse = info parser modifier - where - parser = DispatchParse <$> strArgument (metavar "FILE" <> help "the file to parse") - modifier = fullDesc - <> progDesc "Parse a spark file and check for syntactic errors." - -parseCompile :: ParserInfo Dispatch -parseCompile = info parser modifier - where - parser = DispatchCompile - <$> argument auto - (metavar "CARD" <> help "the card file to compile") - modifier = fullDesc - <> progDesc "Compile a spark card." - -parseCheck :: ParserInfo Dispatch -parseCheck = info parser modifier - where - parser = DispatchCheck - <$> argument auto - (metavar "CARD" <> help "the card to check") - modifier = fullDesc - <> progDesc "Check the deployment of a spark card." - -parseDeploy :: ParserInfo Dispatch -parseDeploy = info parser modifier - where - parser = DispatchDeploy - <$> argument auto - (metavar "CARD" <> help "the card to deploy") -- TODO more help - modifier = fullDesc - <> progDesc "Deploy a spark card." - - -parseGlobalOptions :: Parser GlobalOptions -parseGlobalOptions = GlobalOptions - <$> option (Just <$> str) - ( long "output" - <> short 'o' - <> value Nothing - <> metavar "FILE" - <> help "The output file for compilation" ) - <*> 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." ) diff --git a/src/Check.hs b/src/Check.hs deleted file mode 100644 --- a/src/Check.hs +++ /dev/null @@ -1,17 +0,0 @@ -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 - - diff --git a/src/Check/Internal.hs b/src/Check/Internal.hs deleted file mode 100644 --- a/src/Check/Internal.hs +++ /dev/null @@ -1,244 +0,0 @@ -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 - - diff --git a/src/Check/Types.hs b/src/Check/Types.hs deleted file mode 100644 --- a/src/Check/Types.hs +++ /dev/null @@ -1,50 +0,0 @@ -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) - diff --git a/src/Compiler.hs b/src/Compiler.hs deleted file mode 100644 --- a/src/Compiler.hs +++ /dev/null @@ -1,95 +0,0 @@ -module Compiler where - -import Compiler.Internal -import Compiler.Types -import Control.Monad (when) -import Data.Aeson (eitherDecode) -import Data.Aeson.Encode.Pretty (encodePretty) -import qualified Data.ByteString.Lazy.Char8 as BS -import Data.List (find, stripPrefix) -import Language.Types -import Parser -import PreCompiler -import System.FilePath (takeDirectory, ()) -import Types - -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 - - -- 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 - out <- asks conf_compile_output - liftIO $ do - let bs = encodePretty deps - case out of - Nothing -> BS.putStrLn bs - Just fp -> BS.writeFile fp bs - -inputCompiled :: FilePath -> Sparker [Deployment] -inputCompiled fp = 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 - - diff --git a/src/Compiler/Internal.hs b/src/Compiler/Internal.hs deleted file mode 100644 --- a/src/Compiler/Internal.hs +++ /dev/null @@ -1,64 +0,0 @@ -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] }) - diff --git a/src/Compiler/Types.hs b/src/Compiler/Types.hs deleted file mode 100644 --- a/src/Compiler/Types.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# 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) - diff --git a/src/Compiler/Utils.hs b/src/Compiler/Utils.hs deleted file mode 100644 --- a/src/Compiler/Utils.hs +++ /dev/null @@ -1,39 +0,0 @@ -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 - diff --git a/src/Config.hs b/src/Config.hs deleted file mode 100644 --- a/src/Config.hs +++ /dev/null @@ -1,14 +0,0 @@ -module Config where - -import Config.Types - -defaultConfig :: SparkConfig -defaultConfig = Config - { conf_compile_output = Nothing - , 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 - } diff --git a/src/Config/Types.hs b/src/Config/Types.hs deleted file mode 100644 --- a/src/Config/Types.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Config.Types where - -import CoreTypes - -data SparkConfig = Config - { conf_compile_output :: Maybe FilePath - , 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) diff --git a/src/Constants.hs b/src/Constants.hs deleted file mode 100644 --- a/src/Constants.hs +++ /dev/null @@ -1,67 +0,0 @@ -module Constants where - -keywordCard :: String -keywordCard = "card" - -keywordSpark :: String -keywordSpark = "spark" - -keywordFile :: String -keywordFile = "file" - -keywordInto :: String -keywordInto = "into" - -keywordOutof :: String -keywordOutof = "outof" - -keywordKindOverride :: String -keywordKindOverride = "kind" - -keywordLink :: String -keywordLink = "link" - -keywordCopy :: String -keywordCopy = "copy" - -keywordAlternatives :: String -keywordAlternatives = "alternatives" - -linkKindSymbol :: String -linkKindSymbol = "l->" - -copyKindSymbol :: String -copyKindSymbol = "c->" - -unspecifiedKindSymbol :: String -unspecifiedKindSymbol = "->" - -bracesChars :: [Char] -bracesChars = ['{','}'] - -linespaceChars :: [Char] -linespaceChars = [' ', '\t'] - -endOfLineChars :: [Char] -endOfLineChars = ['\n','\r'] - -whitespaceChars :: [Char] -whitespaceChars = linespaceChars ++ endOfLineChars - -lineDelimiter :: String -lineDelimiter = ";" - -branchDelimiter :: String -branchDelimiter = ":" - -quotesChar :: Char -quotesChar = '"' - -lineCommentStr :: String -lineCommentStr = "#" - -blockCommentStrs :: (String, String) -blockCommentStrs = ("[[", "]]") - -sparkExtension :: String -sparkExtension = "sus" diff --git a/src/CoreTypes.hs b/src/CoreTypes.hs deleted file mode 100644 --- a/src/CoreTypes.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# 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" - diff --git a/src/Deployer.hs b/src/Deployer.hs deleted file mode 100644 --- a/src/Deployer.hs +++ /dev/null @@ -1,48 +0,0 @@ -module Deployer where - -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, 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 () - - -- Check again - let ds = map fst dcrs - dcrs2 <- liftIO $ check ds - - -- 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)?" - - -- 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 - err :: [(Deployment, DeploymentCheckResult)] -> String -> Sparker () - err dcrs text = do - liftIO $ putStrLn $ formatDeploymentChecks dcrs - throwError $ DeployError text - - diff --git a/src/Deployer/Internal.hs b/src/Deployer/Internal.hs deleted file mode 100644 --- a/src/Deployer/Internal.hs +++ /dev/null @@ -1,94 +0,0 @@ -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 - diff --git a/src/Deployer/Types.hs b/src/Deployer/Types.hs deleted file mode 100644 --- a/src/Deployer/Types.hs +++ /dev/null @@ -1,38 +0,0 @@ -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) - - diff --git a/src/Dispatch.hs b/src/Dispatch.hs deleted file mode 100644 --- a/src/Dispatch.hs +++ /dev/null @@ -1,36 +0,0 @@ -module Dispatch (dispatch) where - -import Check -import Compiler -import Compiler.Types -import Control.Monad (void) -import Deployer -import Deployer.Types -import Dispatch.Types -import Parser -import Seed -import Types - -dispatch :: Dispatch -> Sparker () -dispatch (DispatchParse fp) = do - void $ parseFile fp -- Just parse, throw away the results. - -dispatch (DispatchCompile cfr) = do - deployments <- compileJob cfr - outputCompiled deployments - -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 <- 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 diff --git a/src/Dispatch/Types.hs b/src/Dispatch/Types.hs deleted file mode 100644 --- a/src/Dispatch/Types.hs +++ /dev/null @@ -1,19 +0,0 @@ -module Dispatch.Types where - -import Types - -import Deployer.Types -import Language.Types - - -type Instructions = (Dispatch, SparkConfig) - -data Dispatch - = DispatchParse FilePath - | DispatchCompile CardFileReference - | DispatchCheck DeployerCardReference - | DispatchDeploy DeployerCardReference - deriving (Show, Eq) - -type Options = (Dispatch, GlobalOptions) - diff --git a/src/Import.hs b/src/Import.hs new file mode 100644 --- /dev/null +++ b/src/Import.hs @@ -0,0 +1,26 @@ +module Import + ( module X + ) where + +import Prelude as X hiding (readFile, appendFile, writeFile, putStr, putStrLn) + +import Control.Arrow as X +import Data.Maybe as X +import GHC.Generics as X +import System.Exit as X +import Text.Read as X (readEither) + +import Data.IOString as X +import Path as X +import Path.IO as X + +import Control.Monad as X +import Control.Monad.Except as X +import Control.Monad.IO.Class as X (MonadIO(..)) +import Control.Monad.Identity as X +import Control.Monad.Reader as X +import Control.Monad.State as X +import Control.Monad.Writer as X + +import Data.Validity as X +import Data.Validity.Path as X () diff --git a/src/Language/Types.hs b/src/Language/Types.hs deleted file mode 100644 --- a/src/Language/Types.hs +++ /dev/null @@ -1,61 +0,0 @@ -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) - diff --git a/src/Monad.hs b/src/Monad.hs deleted file mode 100644 --- a/src/Monad.hs +++ /dev/null @@ -1,25 +0,0 @@ -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 - diff --git a/src/Parser.hs b/src/Parser.hs deleted file mode 100644 --- a/src/Parser.hs +++ /dev/null @@ -1,20 +0,0 @@ -module Parser where - -import Control.Exception (try) -import Language.Types -import Parser.Internal -import Types - - -parseFile :: FilePath -> Sparker SparkFile -parseFile file = do - 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 - -parseFileIO :: FilePath -> IO (Either ParseError SparkFile) -parseFileIO file = (liftIO $ readFile file) >>= return . parseCardFile file diff --git a/src/Parser/Internal.hs b/src/Parser/Internal.hs deleted file mode 100644 --- a/src/Parser/Internal.hs +++ /dev/null @@ -1,282 +0,0 @@ -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 () diff --git a/src/PreCompiler.hs b/src/PreCompiler.hs deleted file mode 100644 --- a/src/PreCompiler.hs +++ /dev/null @@ -1,57 +0,0 @@ -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 () diff --git a/src/Seed.hs b/src/Seed.hs deleted file mode 100644 --- a/src/Seed.hs +++ /dev/null @@ -1,25 +0,0 @@ -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 ) diff --git a/src/Spark.hs b/src/Spark.hs deleted file mode 100644 --- a/src/Spark.hs +++ /dev/null @@ -1,22 +0,0 @@ -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 diff --git a/src/SuperUserSpark.hs b/src/SuperUserSpark.hs new file mode 100644 --- /dev/null +++ b/src/SuperUserSpark.hs @@ -0,0 +1,24 @@ +module SuperUserSpark + ( spark + ) where + +import Import + +import SuperUserSpark.Bake +import SuperUserSpark.Check +import SuperUserSpark.Compiler +import SuperUserSpark.Deployer +import SuperUserSpark.Diagnose +import SuperUserSpark.OptParse +import SuperUserSpark.Parser + +spark :: IO () +spark = getDispatch >>= dispatch + +dispatch :: Dispatch -> IO () +dispatch (DispatchParse pas) = parseFromArgs pas +dispatch (DispatchCompile cas) = compileFromArgs cas +dispatch (DispatchBake bas) = bakeFromArgs bas +dispatch (DispatchDiagnose bas) = diagnoseFromArgs bas +dispatch (DispatchCheck cas) = checkFromArgs cas +dispatch (DispatchDeploy das) = deployFromArgs das diff --git a/src/SuperUserSpark/Bake.hs b/src/SuperUserSpark/Bake.hs new file mode 100644 --- /dev/null +++ b/src/SuperUserSpark/Bake.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE RecordWildCards #-} + +{- + The responsibility of the baker is to turn raw deployments into baked + deployments. This takes care of everything that couldn't happen during + compilation yet. The differences between raw deployments and baked + deployments are: + - Baked deployments only deal with absolute filepaths so as to be + working-directory-independent. + - Baked deployments are aware of the kind of things the checker/deployer + will be operating on (files versus directories). + + The baker is not responsible for checking any existences. +-} +module SuperUserSpark.Bake where + +import Import + +import qualified Data.Aeson.Encode.Pretty as JSON +import System.Environment (getEnvironment) +import System.FilePath (takeExtension) + +import SuperUserSpark.Bake.Internal +import SuperUserSpark.Bake.Types +import SuperUserSpark.Compiler +import SuperUserSpark.Compiler.Types +import SuperUserSpark.Language.Types +import SuperUserSpark.OptParse.Types +import SuperUserSpark.Utils + +bakeFromArgs :: BakeArgs -> IO () +bakeFromArgs ba = do + errOrAss <- bakeAssignment ba + case errOrAss of + Left be -> die $ unwords ["Failed to build bake assignment:", be] + Right ass -> bake ass + +bakeAssignment :: BakeArgs -> IO (Either String BakeAssignment) +bakeAssignment BakeArgs {..} = do + errOrCardRef <- parseBakeCardReference bakeCardRef + case errOrCardRef of + Left err -> pure $ Left err + Right cardRef -> + BakeAssignment cardRef <$$> deriveBakeSettings cardRef bakeFlags + +parseBakeCardReference :: String -> IO (Either String BakeCardReference) +parseBakeCardReference s = + case words s of + [fp] -> + if takeExtension fp == ".sus" + then BakeCardUncompiled <$$> parseStrongCardFileReference fp + else BakeCardCompiled <$$> resolveFile'Either fp + [f, c] -> + BakeCardUncompiled <$$> + ((\(StrongCardFileReference p _) -> + StrongCardFileReference p (Just $ CardNameReference c)) <$$> + parseStrongCardFileReference f) + _ -> pure $ Left $ unwords ["Could not parse card reference from:", s] + +deriveBakeSettings :: BakeCardReference + -> BakeFlags + -> IO (Either String BakeSettings) +deriveBakeSettings bcr BakeFlags {..} = + BakeSettings (rootOf bcr) <$$> (Right <$> getEnvironment) <**> + deriveCompileSettings bakeCompileFlags + +rootOf :: BakeCardReference -> Path Abs Dir +rootOf bcr = + parent $ + case bcr of + (BakeCardCompiled fp) -> fp + (BakeCardUncompiled (StrongCardFileReference fp _)) -> fp + +bake :: BakeAssignment -> IO () +bake BakeAssignment {..} = do + errOrDone <- + runReaderT (runExceptT $ bakeByCardRef bakeCardReference) bakeSettings + case errOrDone of + Left err -> die $ formatBakeError err + Right () -> pure () + +formatBakeError :: BakeError -> String +formatBakeError (BakeCompileError ce) = formatCompileError ce +formatBakeError (BakeError s) = unwords ["Bake failed:", s] + +bakeByCardRef :: BakeCardReference -> SparkBaker () +bakeByCardRef bakeCardReference = do + deps <- compileBakeCardRef bakeCardReference + bdeps <- bakeDeployments deps + putStrLn $ JSON.encodePretty bdeps + +compileBakeCardRef :: BakeCardReference -> SparkBaker [RawDeployment] +compileBakeCardRef (BakeCardCompiled fp) = bakerCompile $ inputCompiled fp +compileBakeCardRef (BakeCardUncompiled bcf) = bakerCompile $ compileJob bcf + +bakerCompile :: ImpureCompiler a -> SparkBaker a +bakerCompile = + withExceptT BakeCompileError . mapExceptT (withReaderT bakeCompileSettings) diff --git a/src/SuperUserSpark/Bake/Internal.hs b/src/SuperUserSpark/Bake/Internal.hs new file mode 100644 --- /dev/null +++ b/src/SuperUserSpark/Bake/Internal.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE RecordWildCards #-} + +module SuperUserSpark.Bake.Internal where + +import Import + +import Control.Exception (try) +import System.FilePath + (isAbsolute, replaceDirectory, takeDirectory) + +import SuperUserSpark.Bake.Types +import SuperUserSpark.Compiler.Types + +bakeDeployments :: [RawDeployment] -> SparkBaker [BakedDeployment] +bakeDeployments = mapM bakeDeployment + +bakeDeployment :: RawDeployment -> SparkBaker BakedDeployment +bakeDeployment Deployment {..} = do + d <- bakeDirections deploymentDirections + pure $ + Deployment {deploymentDirections = d, deploymentKind = deploymentKind} + +bakeDirections :: DeploymentDirections FilePath + -> SparkBaker (DeploymentDirections AbsP) +bakeDirections (Directions srcs dst) = + Directions <$> mapM bakeFilePath srcs <*> bakeFilePath dst + +-- | Bake asingle 'FilePath' +-- +-- The result should: +-- +-- * ... not contain any more variables. +-- * ... not contain any reference to the home directory: @~@. +-- * ... be absolute. +bakeFilePath :: FilePath -> SparkBaker AbsP +bakeFilePath fp = do + env <- asks bakeEnvironment + root <- asks bakeRoot + case complete env fp of + Left err -> throwError $ BakeError $ err + Right cp -> do + if isAbsolute cp + then case parseAbsFile cp of + Left err -> throwError $ BakeError $ show err + Right af -> pure $ AbsP af + else do + let dir = takeDirectory cp + errOrAp <- + liftIO $ + try $ do + d <- resolveFile root dir + parseAbsFile $ replaceDirectory cp $ toFilePath d + case errOrAp of + Left err -> + throwError $ + BakeError $ show (err :: PathParseException) + Right absp -> pure $ AbsP absp + +type Environment = [(String, String)] + +complete :: Environment -> FilePath -> Either String FilePath +complete env fp = do + let ids = parseId fp + strs <- mapM (replaceId env) ids + return $ concat strs + +parseId :: FilePath -> [ID] +parseId fp = + case fp of + ('~':rest) -> Var "HOME" : go rest + _ -> go fp + where + go :: FilePath -> [ID] + go [] = [] + go ('$':'(':rest) = (Var id_) : (go next) + where + (id_, (')':next)) = break (\c -> c == ')') rest + go (s:ss) = + case go 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 diff --git a/src/SuperUserSpark/Bake/Types.hs b/src/SuperUserSpark/Bake/Types.hs new file mode 100644 --- /dev/null +++ b/src/SuperUserSpark/Bake/Types.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveGeneric #-} + +module SuperUserSpark.Bake.Types where + +import Import + +import Data.Aeson + +import SuperUserSpark.Compiler.Types + +data BakeAssignment = BakeAssignment + { bakeCardReference :: BakeCardReference + , bakeSettings :: BakeSettings + } deriving (Show, Eq, Generic) + +instance Validity BakeAssignment + +data BakeCardReference + = BakeCardCompiled (Path Abs File) + | BakeCardUncompiled StrongCardFileReference + deriving (Show, Eq, Generic) + +instance Validity BakeCardReference + +data BakeSettings = BakeSettings + { bakeRoot :: Path Abs Dir + , bakeEnvironment :: [(String, String)] + , bakeCompileSettings :: CompileSettings + } deriving (Show, Eq, Generic) + +instance Validity BakeSettings + +defaultBakeSettings :: BakeSettings +defaultBakeSettings = + BakeSettings + { bakeRoot = $(mkAbsDir "/") + , bakeEnvironment = [] + , bakeCompileSettings = defaultCompileSettings + } + +type SparkBaker = ExceptT BakeError (ReaderT BakeSettings IO) + +data BakeError + = BakeCompileError CompileError + | BakeError String + deriving (Show, Eq, Generic) + +instance Validity BakeError + +type BakedDeployment = Deployment AbsP + +-- | An absolute path. +-- +-- This is kept as a 'Path Abs File' to avoid existential quantification, but +-- that is an implementation detail and should not be exposed as functionality. +newtype AbsP = AbsP + { unAbsP :: Path Abs File + } deriving (Show, Eq, Generic) + +instance Validity AbsP + +instance ToJSON AbsP where + toJSON (AbsP p) = toJSON p + +instance FromJSON AbsP where + parseJSON v = AbsP <$> parseJSON v + +toPath :: AbsP -> FilePath +toPath = toFilePath . unAbsP + +data ID + = Plain String + | Var String + deriving (Show, Eq, Generic) + +instance Validity ID diff --git a/src/SuperUserSpark/Check.hs b/src/SuperUserSpark/Check.hs new file mode 100644 --- /dev/null +++ b/src/SuperUserSpark/Check.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE RecordWildCards #-} + +module SuperUserSpark.Check + ( checkFromArgs + , checkAssignment + , deriveCheckSettings + , check + , formatCheckError + , formatDeploymentChecks + , checkDeployments + ) where + +import Import + +import SuperUserSpark.Bake +import SuperUserSpark.Bake.Internal +import SuperUserSpark.Bake.Types +import SuperUserSpark.Check.Internal +import SuperUserSpark.Check.Types +import SuperUserSpark.Diagnose +import SuperUserSpark.Diagnose.Types +import SuperUserSpark.OptParse.Types +import SuperUserSpark.Utils + +checkFromArgs :: CheckArgs -> IO () +checkFromArgs cas = do + errOrAss <- checkAssignment cas + case errOrAss of + Left err -> die $ unwords ["Failed to build Check assignment:", err] + Right ass -> check ass + +checkAssignment :: CheckArgs -> IO (Either String CheckAssignment) +checkAssignment CheckArgs {..} = do + errOrCardRef <- parseBakeCardReference checkArgCardRef + case errOrCardRef of + Left err -> pure $ Left err + Right cardRef -> + CheckAssignment cardRef <$$> deriveCheckSettings cardRef checkFlags + +deriveCheckSettings :: BakeCardReference + -> CheckFlags + -> IO (Either String CheckSettings) +deriveCheckSettings bcr CheckFlags {..} = + CheckSettings <$$> deriveDiagnoseSettings bcr checkDiagnoseFlags + +check :: CheckAssignment -> IO () +check CheckAssignment {..} = do + errOrDone <- + runReaderT + (runExceptT $ checkByCardRef checkCardReference) + checkSettings + case errOrDone of + Left err -> die $ formatCheckError err + Right () -> pure () + +formatCheckError :: CheckError -> String +formatCheckError (CheckDiagnoseError ce) = formatDiagnoseError ce +formatCheckError (CheckError s) = unwords ["Check failed:", s] + +checkByCardRef :: BakeCardReference -> SparkChecker () +checkByCardRef checkCardReference = do + ddeps <- + checkerDiagnose $ + diagnoserBake + (compileBakeCardRef checkCardReference >>= bakeDeployments) >>= + (liftIO . diagnoseDeployments) + liftIO $ putStrLn $ formatDeploymentChecks $ zip ddeps $ checkDeployments ddeps + +checkerDiagnose :: SparkDiagnoser a -> SparkChecker a +checkerDiagnose = + withExceptT CheckDiagnoseError . + mapExceptT (withReaderT checkDiagnoseSettings) + +checkDeployments :: [DiagnosedDeployment] -> [DeploymentCheckResult] +checkDeployments = map checkDeployment diff --git a/src/SuperUserSpark/Check/Internal.hs b/src/SuperUserSpark/Check/Internal.hs new file mode 100644 --- /dev/null +++ b/src/SuperUserSpark/Check/Internal.hs @@ -0,0 +1,277 @@ +module SuperUserSpark.Check.Internal where + +import Import + +import Data.Maybe (catMaybes) + +import SuperUserSpark.Bake.Types +import SuperUserSpark.Check.Types +import SuperUserSpark.Compiler.Types +import SuperUserSpark.Constants +import SuperUserSpark.CoreTypes +import SuperUserSpark.Diagnose.Types + +checkDeployment :: DiagnosedDeployment -> DeploymentCheckResult +checkDeployment (Deployment (Directions [] (D dst _ _)) _) = + ImpossibleDeployment + [unwords ["No source for deployment with destination", toPath dst]] +checkDeployment (Deployment (Directions 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 = + let parseBoth cons p = + case (p $ toPath src, p $ toPath dst) of + (Left err1, Left err2) -> + Impossible $ unwords [show err1, show err2] + (Left err, _) -> Impossible $ show err + (_, Left err) -> Impossible $ show err + (Right s, Right d) -> Ready $ cons s d + readyCopyFile = parseBoth CopyFile parseAbsFile + readyCopyDir = parseBoth CopyDir parseAbsDir + readyLinkFile = parseBoth LinkFile parseAbsFile + readyLinkDir = parseBoth LinkDir parseAbsDir + in case (srcd, dstd, kind) of + (IsFile, Nonexistent, CopyDeployment) -> readyCopyFile + (IsFile, Nonexistent, LinkDeployment) -> readyLinkFile + (IsFile, IsFile, LinkDeployment) -> + e + readyLinkFile + [ "Both the source:" + , toPath src + , "and the destination:" + , toPath dst + , "are files for a link deployment." + ] + (IsFile, IsFile, CopyDeployment) -> + if srch == dsth + then AlreadyDone + else e + readyCopyFile + [ "Both the source:" + , toPath src + , "and the destination:" + , toPath dst + , "are files for a copy deployment, but they are not equal." + ] + (IsFile, IsDirectory, LinkDeployment) -> + e + readyLinkFile + [ "The source: " + , toPath src + , "is a file but the destination:" + , toPath dst + , "is a directory for a link deployment." + ] + (IsFile, IsDirectory, CopyDeployment) -> + e + readyCopyFile + [ "The source: " + , toPath src + , "is a file but the destination:" + , toPath dst + , "is a directory for a copy deployment." + ] + (IsFile, IsLinkTo l, LinkDeployment) -> + if l == src + then AlreadyDone + else e + readyLinkFile + [ "The source:" + , toPath src + , "is a file and the destination:" + , toPath dst + , "is a link for a link deployment but the destination does not point to the source. Instead it points to:" + , toPath l ++ "." + ] + (IsFile, IsLinkTo _, CopyDeployment) -> + e + readyCopyFile + [ "The source:" + , toPath src + , "is a file and the destination:" + , toPath dst + , "is a link for a copy deployment." + ] + (IsDirectory, Nonexistent, LinkDeployment) -> readyLinkDir + (IsDirectory, Nonexistent, CopyDeployment) -> readyCopyDir + (IsDirectory, IsFile, LinkDeployment) -> + e + readyLinkDir + [ "The source:" + , toPath src + , "is a directory and the destination:" + , toPath dst + , "is a file for a link deployment" + ] + (IsDirectory, IsFile, CopyDeployment) -> + e + readyCopyDir + [ "The source:" + , toPath src + , "is a directory and the destination:" + , toPath dst + , "is a file for a copy deployment" + ] + (IsDirectory, IsDirectory, LinkDeployment) -> + e + readyLinkDir + [ "The source:" + , toPath src + , "and the destination:" + , toPath dst + , "are directories for a link deployment." + ] + (IsDirectory, IsDirectory, CopyDeployment) -> + if srch == dsth + then AlreadyDone + else e + readyCopyDir + [ "The source:" + , toPath src + , "and destination:" + , toPath dst + , "are directories for a copy deployment, but they are not equal." + ] + (IsDirectory, IsLinkTo l, LinkDeployment) -> + if l == src + then AlreadyDone + else e + readyLinkDir + [ "The source:" + , toPath src + , "is a directory and the destination:" + , toPath dst + , "is a link for a link deployment but the destination does not point to the source. Instead it points to:" + , toPath l ++ "." + ] + (IsDirectory, IsLinkTo _, CopyDeployment) -> + e + readyCopyDir + [ "The source:" + , toPath src + , "is a directory and the destination:" + , toPath dst + , "is a link for a copy deployment." + ] + (Nonexistent, _, _) -> + i ["The source:", toPath src, "does not exist."] + (IsLinkTo _, _, _) -> i ["The source:", toPath src, "is a link."] + (IsWeird, IsWeird, _) -> + i + [ "Both the source:" + , toPath src + , "and the destination:" + , toPath dst + , "are weird." + ] + (IsWeird, _, _) -> i ["The source:", toPath src, "is weird."] + (_, IsWeird, _) -> i ["The destination:", toPath dst, "is weird."] + where + i = Impossible . unlines + e mins s = + case mins of + (Impossible _) -> mins + (Ready ins) -> + case dstd of + IsFile -> Dirty (unlines s) ins $ CleanFile $ unAbsP dst + IsLinkTo _ -> Dirty (unlines s) ins $ CleanLink $ unAbsP dst + IsDirectory -> + case parseAbsDir $ toPath dst of + Left err -> Impossible $ show err -- Should not happen, but just in case. + Right dir -> + Dirty (unlines s) ins $ CleanDirectory dir + _ -> Impossible "should not occur" + _ -> Impossible "should not occur." + +formatDeploymentChecks :: [(DiagnosedDeployment, 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 :: (DiagnosedDeployment, DeploymentCheckResult) + -> Maybe String +formatDeploymentCheck (_, (ReadyToDeploy is)) = + Just $ "READY: " ++ formatInstruction is +formatDeploymentCheck (_, DeploymentDone) = Nothing +formatDeploymentCheck (d, ImpossibleDeployment ds) = + Just $ + concat + [ "IMPOSSIBLE: " + , toPath $ + diagnosedFilePath $ directionDestination $ deploymentDirections d + , " cannot be deployed:\n" + , unlines ds + , "\n" + ] +formatDeploymentCheck (d, (DirtySituation str is c)) = + Just $ + concat + [ "DIRTY: " + , toPath $ + diagnosedFilePath $ directionDestination $ deploymentDirections d + , "\n" + , str + , "planned: " + , formatInstruction is + , "\n" + , "cleanup needed:\n" + , formatCleanupInstruction c + , "\n" + ] + +formatInstruction :: Instruction -> String +formatInstruction (CopyFile from to) = + unwords $ [toFilePath from, "c->", toFilePath to] +formatInstruction (CopyDir from to) = + unwords $ [toFilePath from, "c->", toFilePath to] +formatInstruction (LinkFile from to) = + unwords $ [toFilePath from, "l->", toFilePath to] +formatInstruction (LinkDir from to) = + unwords $ [toFilePath from, "l->", toFilePath to] + +formatCleanupInstruction :: CleanupInstruction -> String +formatCleanupInstruction (CleanFile fp) = "remove file " ++ toFilePath fp +formatCleanupInstruction (CleanDirectory dir) = + "remove directory " ++ toFilePath dir +formatCleanupInstruction (CleanLink link) = "remove link " ++ toFilePath link diff --git a/src/SuperUserSpark/Check/Types.hs b/src/SuperUserSpark/Check/Types.hs new file mode 100644 --- /dev/null +++ b/src/SuperUserSpark/Check/Types.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RecordWildCards #-} + +module SuperUserSpark.Check.Types where + +import Import + +import SuperUserSpark.Bake.Types +import SuperUserSpark.Diagnose.Types + +data CheckAssignment = CheckAssignment + { checkCardReference :: BakeCardReference + , checkSettings :: CheckSettings + } deriving (Show, Eq, Generic) + +instance Validity CheckAssignment + +data CheckSettings = CheckSettings + { checkDiagnoseSettings :: DiagnoseSettings + } deriving (Show, Eq, Generic) + +instance Validity CheckSettings + +defaultCheckSettings :: CheckSettings +defaultCheckSettings = + CheckSettings {checkDiagnoseSettings = defaultDiagnoseSettings} + +type SparkChecker = ExceptT CheckError (ReaderT CheckSettings IO) + +data CheckError + = CheckDiagnoseError DiagnoseError + | CheckError String + deriving (Show, Eq, Generic) + +instance Validity CheckError + +data Instruction + = CopyFile (Path Abs File) + (Path Abs File) + | CopyDir (Path Abs Dir) + (Path Abs Dir) + | LinkFile (Path Abs File) + (Path Abs File) + | LinkDir (Path Abs Dir) + (Path Abs Dir) + deriving (Show, Eq, Generic) + +instance Validity Instruction + +data CleanupInstruction + = CleanFile (Path Abs File) + | CleanDirectory (Path Abs Dir) + | CleanLink (Path Abs File) + deriving (Show, Eq, Generic) + +instance Validity CleanupInstruction + +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, Generic) + +instance Validity DeploymentCheckResult + +data CheckResult + = AlreadyDone -- ^ Done already + | Ready Instruction -- ^ Immediately possible + | Dirty String + Instruction + CleanupInstruction -- ^ Possible after cleanup + | Impossible String -- ^ Entirely impossible + deriving (Show, Eq, Generic) + +instance Validity CheckResult diff --git a/src/SuperUserSpark/Compiler.hs b/src/SuperUserSpark/Compiler.hs new file mode 100644 --- /dev/null +++ b/src/SuperUserSpark/Compiler.hs @@ -0,0 +1,201 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} + +{- + The Compiler is responsible for transforming an AST into a list of + deployments. A deployment knows about the possible sources, the + destination, and how to deploy a source to a destination. + + Everything that the compiler does needs to be independent of the host + system because compilation could have happened independently of deployment. + + As such, raw deployments still contain references to variables such as: + - Environment variables + - The home directory: @~@ +-} +module SuperUserSpark.Compiler where + +import Import hiding (()) + +import Control.Exception (try) +import Data.Aeson (eitherDecode) +import Data.Aeson.Encode.Pretty (encodePretty) +import Data.List (find) + +import SuperUserSpark.Compiler.Internal +import SuperUserSpark.Compiler.Types +import SuperUserSpark.CoreTypes +import SuperUserSpark.Language.Types +import SuperUserSpark.OptParse.Types +import SuperUserSpark.Parser +import SuperUserSpark.PreCompiler +import SuperUserSpark.Utils + +compileFromArgs :: CompileArgs -> IO () +compileFromArgs ca = do + errOrrAss <- compileAssignment ca + case errOrrAss of + Left ce -> die $ unwords ["Failed to build compile assignment:", ce] + Right ass -> compile ass + +compileAssignment :: CompileArgs -> IO (Either String CompileAssignment) +compileAssignment CompileArgs {..} = + CompileAssignment <$$> (parseStrongCardFileReference compileArgCardRef) <**> + (case compileArgOutput of + Nothing -> pure $ pure Nothing + Just f -> do + af <- + left (show :: PathParseException -> String) <$> + try (resolveFile' f) + pure $ Just <$> af) <**> + deriveCompileSettings compileFlags + +resolveFile'Either :: FilePath -> IO (Either String (Path Abs File)) +resolveFile'Either fp = do + errOrSp <- try $ resolveFile' fp + pure $ left (show :: PathParseException -> String) $ errOrSp + +parseStrongCardFileReference :: FilePath + -> IO (Either String StrongCardFileReference) +parseStrongCardFileReference fp = + (\sfp -> StrongCardFileReference sfp Nothing) <$$> resolveFile'Either fp + +deriveCompileSettings :: CompileFlags -> IO (Either String CompileSettings) +deriveCompileSettings CompileFlags {..} = + CompileSettings <$$> + (pure $ + case compileDefaultKind of + Nothing -> Right LinkDeployment + Just s -> readEither s) <**> + (pure $ + case compileKindOverride of + Nothing -> Right Nothing + Just s -> readEither s) + +compile :: CompileAssignment -> IO () +compile CompileAssignment {..} = do + errOrDone <- + runReaderT + (runExceptT $ + compileJob compileCardReference >>= outputCompiled compileOutput) + compileSettings + case errOrDone of + Left ce -> die $ formatCompileError ce + Right () -> pure () + +formatCompileError :: CompileError -> String +formatCompileError (CompileParseError s) = unlines ["Parse failed:", show s] +formatCompileError (PreCompileErrors ss) = + unlines $ "Precompilation checks failed:" : map show ss +formatCompileError (DuringCompilationError s) = + unlines ["Compilation failed:", s] + +decideCardToCompile :: StrongCardFileReference + -> [Card] + -> Either CompileError Card +decideCardToCompile (StrongCardFileReference fp mcn) scope = + case mcn of + Nothing -> + case scope of + [] -> + Left $ + DuringCompilationError $ + unwords + [ "No cards found for compilation in file:" + , toFilePath fp + ] + -- TODO more detailed error here + (fst_:_) -> pure fst_ + Just (CardNameReference name) -> do + case find (\c -> cardName c == name) scope of + Nothing -> + Left $ + DuringCompilationError $ + unwords ["Card", name, "not found for compilation."] -- TODO more detailed error here + Just cu -> return cu + +throwEither :: Either CompileError a -> ImpureCompiler a +throwEither (Left e) = throwError e +throwEither (Right a) = pure a + +injectBase :: Maybe (Path Rel Dir) -> Card -> Card +injectBase Nothing c = c +injectBase (Just base) (Card name s) = + Card name $ Block [OutofDir $ toFilePath base, s] + +compileJob :: StrongCardFileReference -> ImpureCompiler [RawDeployment] +compileJob cr@(StrongCardFileReference root _) = + compileJobWithRoot root Nothing cr + +compileJobWithRoot + :: Path Abs File + -> Maybe (Path Rel Dir) + -> StrongCardFileReference + -> ImpureCompiler [RawDeployment] +compileJobWithRoot root base cfr@(StrongCardFileReference fp _) = do + sf <- compilerParse fp + unit <- throwEither $ decideCardToCompile cfr $ sparkFileCards sf + -- Inject base outofDir + let injected = injectBase base unit + -- Precompile checks + let pces = preCompileChecks injected + when (not . null $ pces) $ throwError $ PreCompileErrors pces + -- Compile this unit + (deps, crfs) <- embedPureCompiler $ compileUnit injected + -- Compile the rest of the units + rcrfs <- mapM (resolveCardReferenceRelativeTo fp) crfs + restDeps <- + fmap concat $ + forM rcrfs $ \rcrf -> + case rcrf of + (StrongCardFile cfr_@(StrongCardFileReference base2 _)) -> do + let (newRoot, newBase) = + case stripDir (parent root) (parent base2) of + Nothing -> (base2, Nothing) + Just d -> (root, Just d) + compileJobWithRoot newRoot newBase cfr_ + (StrongCardName cnr) -> + compileJobWithRoot + root + base + (StrongCardFileReference fp $ Just cnr) + return $ deps ++ restDeps + +resolveCardReferenceRelativeTo :: Path Abs File + -> CardReference + -> ImpureCompiler StrongCardReference +resolveCardReferenceRelativeTo fp (CardFile (CardFileReference cfp mcn)) = do + nfp <- liftIO $ resolveFile (parent fp) cfp + pure $ StrongCardFile $ StrongCardFileReference nfp mcn +resolveCardReferenceRelativeTo _ (CardName cnr) = pure $ StrongCardName cnr + +compilerParse :: Path Abs File -> ImpureCompiler SparkFile +compilerParse fp = do + esf <- liftIO $ parseFile fp + case esf of + Left pe -> throwError $ CompileParseError pe + Right sf_ -> pure sf_ + +embedPureCompiler :: PureCompiler a -> ImpureCompiler a +embedPureCompiler = withExceptT id . mapExceptT (mapReaderT idToIO) + where + idToIO :: Identity a -> IO a + idToIO = return . runIdentity + +outputCompiled :: Maybe (Path Abs File) -> [RawDeployment] -> ImpureCompiler () +outputCompiled out deps = + liftIO $ do + let bs = encodePretty deps + case out of + Nothing -> putStrLn bs + Just fp -> writeFile fp bs + +inputCompiled :: Path Abs File -> ImpureCompiler [RawDeployment] +inputCompiled fp = do + bs <- readFile fp + case eitherDecode bs of + Left err -> + throwError $ + DuringCompilationError $ + "Something went wrong while deserialising json data: " ++ err + Right ds -> return ds diff --git a/src/SuperUserSpark/Compiler/Internal.hs b/src/SuperUserSpark/Compiler/Internal.hs new file mode 100644 --- /dev/null +++ b/src/SuperUserSpark/Compiler/Internal.hs @@ -0,0 +1,52 @@ +module SuperUserSpark.Compiler.Internal where + +import Import hiding (()) + +import System.FilePath (()) + +import SuperUserSpark.Compiler.Types +import SuperUserSpark.Compiler.Utils +import SuperUserSpark.Language.Types + +compileUnit :: Card -> PureCompiler ([RawDeployment], [CardReference]) +compileUnit card = + execWriterT $ evalStateT (compileDecs [cardContent card]) initialState + +compileDecs :: [Declaration] -> InternalCompiler () +compileDecs = mapM_ compileDec + +compileDec :: Declaration -> InternalCompiler () +compileDec (Deploy src dst kind) = do + defaultKind <- asks compileDefaultKind + localOverride <- gets stateDeploymentKindLocalOverride + superOverride <- asks compileKindOverride + let resultKind = + case msum [superOverride, localOverride, kind] of + Nothing -> defaultKind + Just k -> k + outof <- gets stateOutof_prefix + into <- gets stateInto + let directions = + Directions + { directionSources = resolvePrefix $ outof ++ [sources src] + , directionDestination = into dst + } + addDeployment $ Deployment directions resultKind +compileDec (SparkOff cr) = addCardRef cr +compileDec (IntoDir dir) = do + ip <- gets stateInto + if null ip + then modify (\s -> s {stateInto = dir}) + else modify (\s -> s {stateInto = ip dir}) +compileDec (OutofDir dir) = do + op <- gets stateOutof_prefix + modify (\s -> s {stateOutof_prefix = op ++ [Literal dir]}) +compileDec (DeployKindOverride kind) = do + modify (\s -> s {stateDeploymentKindLocalOverride = Just kind}) +compileDec (Block ds) = do + before <- get + compileDecs ds + put before +compileDec (Alternatives ds) = do + op <- gets stateOutof_prefix + modify (\s -> s {stateOutof_prefix = op ++ [Alts ds]}) diff --git a/src/SuperUserSpark/Compiler/Types.hs b/src/SuperUserSpark/Compiler/Types.hs new file mode 100644 --- /dev/null +++ b/src/SuperUserSpark/Compiler/Types.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} + +module SuperUserSpark.Compiler.Types where + +import Import + +import Data.Aeson + (FromJSON(..), ToJSON(..), object, (.:), (.=), withObject) + +import SuperUserSpark.CoreTypes +import SuperUserSpark.Language.Types +import SuperUserSpark.Parser.Types +import SuperUserSpark.PreCompiler.Types + +data CompileAssignment = CompileAssignment + { compileCardReference :: StrongCardFileReference + , compileOutput :: Maybe (Path Abs File) + , compileSettings :: CompileSettings + } deriving (Show, Eq, Generic) + +instance Validity CompileAssignment + +data StrongCardFileReference = + StrongCardFileReference (Path Abs File) + (Maybe CardNameReference) + deriving (Show, Eq, Generic) + +instance Validity StrongCardFileReference + +data StrongCardReference + = StrongCardFile StrongCardFileReference + | StrongCardName CardNameReference + deriving (Show, Eq, Generic) + +instance Validity StrongCardReference + +data CompileSettings = CompileSettings + { compileDefaultKind :: DeploymentKind + , compileKindOverride :: Maybe DeploymentKind + } deriving (Show, Eq, Generic) + +instance Validity CompileSettings + +defaultCompileSettings :: CompileSettings +defaultCompileSettings = + CompileSettings + {compileDefaultKind = LinkDeployment, compileKindOverride = Nothing} + +type RawDeployment = Deployment FilePath + +data Deployment a = Deployment + { deploymentDirections :: DeploymentDirections a + , deploymentKind :: DeploymentKind + } deriving (Show, Eq, Generic) + +instance Validity a => + Validity (Deployment a) + +instance FromJSON a => + FromJSON (Deployment a) where + parseJSON = + withObject "Deployment" $ \o -> + Deployment <$> o .: "directions" <*> o .: "deployment kind" + +instance ToJSON a => + ToJSON (Deployment a) where + toJSON depl = + object + [ "directions" .= deploymentDirections depl + , "deployment kind" .= deploymentKind depl + ] + +instance Functor Deployment where + fmap f (Deployment dis dk) = Deployment (fmap f dis) dk + +data DeploymentDirections a = Directions + { directionSources :: [a] + , directionDestination :: a + } deriving (Show, Eq, Generic) + +instance Validity a => + Validity (DeploymentDirections a) + +instance ToJSON a => + ToJSON (DeploymentDirections a) where + toJSON (Directions srcs dst) = + object ["sources" .= srcs, "destination" .= dst] + +instance FromJSON a => + FromJSON (DeploymentDirections a) where + parseJSON = + withObject "Deployment Directions" $ \o -> + Directions <$> o .: "sources" <*> o .: "destination" + +instance Functor DeploymentDirections where + fmap f (Directions srcs dst) = Directions (map f srcs) (f dst) + +type CompilerPrefix = [PrefixPart] + +data PrefixPart + = Literal String + | Alts [String] + deriving (Show, Eq, Generic) + +instance Validity PrefixPart + +data CompilerState = CompilerState + { stateDeploymentKindLocalOverride :: Maybe DeploymentKind + , stateInto :: Directory + , stateOutof_prefix :: CompilerPrefix + } deriving (Show, Eq, Generic) + +instance Validity CompilerState + +type ImpureCompiler = ExceptT CompileError (ReaderT CompileSettings IO) + +type PureCompiler = ExceptT CompileError (ReaderT CompileSettings Identity) + +type InternalCompiler = StateT CompilerState (WriterT ([RawDeployment], [CardReference]) PureCompiler) + +data CompileError + = CompileParseError ParseError + | PreCompileErrors [PreCompileError] + | DuringCompilationError String + deriving (Show, Eq, Generic) + +instance Validity CompileError diff --git a/src/SuperUserSpark/Compiler/Utils.hs b/src/SuperUserSpark/Compiler/Utils.hs new file mode 100644 --- /dev/null +++ b/src/SuperUserSpark/Compiler/Utils.hs @@ -0,0 +1,37 @@ +module SuperUserSpark.Compiler.Utils where + +import Import hiding (()) + +import SuperUserSpark.Compiler.Types +import SuperUserSpark.Language.Types +import System.FilePath (()) + +initialState :: CompilerState +initialState = + CompilerState + { stateDeploymentKindLocalOverride = Nothing + , stateInto = "" + , stateOutof_prefix = [] + } + +addDeployment :: RawDeployment -> 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 diff --git a/src/SuperUserSpark/Constants.hs b/src/SuperUserSpark/Constants.hs new file mode 100644 --- /dev/null +++ b/src/SuperUserSpark/Constants.hs @@ -0,0 +1,69 @@ +module SuperUserSpark.Constants where + +import Import + +keywordCard :: String +keywordCard = "card" + +keywordSpark :: String +keywordSpark = "spark" + +keywordFile :: String +keywordFile = "file" + +keywordInto :: String +keywordInto = "into" + +keywordOutof :: String +keywordOutof = "outof" + +keywordKindOverride :: String +keywordKindOverride = "kind" + +keywordLink :: String +keywordLink = "link" + +keywordCopy :: String +keywordCopy = "copy" + +keywordAlternatives :: String +keywordAlternatives = "alternatives" + +linkKindSymbol :: String +linkKindSymbol = "l->" + +copyKindSymbol :: String +copyKindSymbol = "c->" + +unspecifiedKindSymbol :: String +unspecifiedKindSymbol = "->" + +bracesChars :: [Char] +bracesChars = ['{', '}'] + +linespaceChars :: [Char] +linespaceChars = [' ', '\t'] + +endOfLineChars :: [Char] +endOfLineChars = ['\n', '\r'] + +whitespaceChars :: [Char] +whitespaceChars = linespaceChars ++ endOfLineChars + +lineDelimiter :: String +lineDelimiter = ";" + +branchDelimiter :: String +branchDelimiter = ":" + +quotesChar :: Char +quotesChar = '"' + +lineCommentStr :: String +lineCommentStr = "#" + +blockCommentStrs :: (String, String) +blockCommentStrs = ("[[", "]]") + +sparkExtension :: String +sparkExtension = "sus" diff --git a/src/SuperUserSpark/CoreTypes.hs b/src/SuperUserSpark/CoreTypes.hs new file mode 100644 --- /dev/null +++ b/src/SuperUserSpark/CoreTypes.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} + +module SuperUserSpark.CoreTypes where + +import Import + +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, Generic) + +instance Validity DeploymentKind + +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" diff --git a/src/SuperUserSpark/Deployer.hs b/src/SuperUserSpark/Deployer.hs new file mode 100644 --- /dev/null +++ b/src/SuperUserSpark/Deployer.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE RecordWildCards #-} + +module SuperUserSpark.Deployer where + +import Import + +import SuperUserSpark.Bake +import SuperUserSpark.Bake.Internal +import SuperUserSpark.Bake.Types +import SuperUserSpark.Check +import SuperUserSpark.Check.Internal +import SuperUserSpark.Check.Types +import SuperUserSpark.Deployer.Internal +import SuperUserSpark.Deployer.Types +import SuperUserSpark.Diagnose +import SuperUserSpark.Diagnose.Types +import SuperUserSpark.OptParse.Types +import SuperUserSpark.Utils + +deployFromArgs :: DeployArgs -> IO () +deployFromArgs das = do + errOrAss <- deployAssignment das + case errOrAss of + Left err -> die $ unwords ["Failed to make Deployment assignment:", err] + Right ass -> deploy ass + +deployAssignment :: DeployArgs -> IO (Either String DeployAssignment) +deployAssignment DeployArgs {..} = do + errOrCardRef <- parseBakeCardReference deployArgCardRef + case errOrCardRef of + Left err -> pure $ Left err + Right cardRef -> + DeployAssignment cardRef <$$> + deriveDeploySettings cardRef deployFlags + +deriveDeploySettings :: BakeCardReference + -> DeployFlags + -> IO (Either String DeploySettings) +deriveDeploySettings bcr DeployFlags {..} = do + ecs <- deriveCheckSettings bcr deployCheckFlags + pure $ do + cs <- ecs + pure + DeploySettings + { deploySetsReplaceLinks = + deployFlagReplaceLinks || deployFlagReplaceAll + , deploySetsReplaceFiles = + deployFlagReplaceFiles || deployFlagReplaceAll + , deploySetsReplaceDirectories = + deployFlagReplaceDirectories || deployFlagReplaceAll + , deployCheckSettings = cs + } + +deploy :: DeployAssignment -> IO () +deploy DeployAssignment {..} = do + errOrDone <- + runReaderT + (runExceptT $ deployByCardRef deployCardReference) + deploySettings + case errOrDone of + Left err -> die $ formatDeployError err + Right () -> pure () + +formatDeployError :: DeployError -> String +formatDeployError (DeployCheckError e) = formatCheckError e +formatDeployError (DeployError s) = unwords ["Deployment failed:", s] + +deployByCardRef :: BakeCardReference -> SparkDeployer () +deployByCardRef dcr = do + deps <- deployerBake $ compileBakeCardRef dcr >>= bakeDeployments + deployAbss deps + +deployerBake :: SparkBaker a -> SparkDeployer a +deployerBake = + withExceptT (DeployCheckError . CheckDiagnoseError . DiagnoseBakeError) . + mapExceptT + (withReaderT $ + diagnoseBakeSettings . checkDiagnoseSettings . deployCheckSettings) + +deployAbss :: [BakedDeployment] -> SparkDeployer () +deployAbss ds = do + stage1 + stage2 + stage3 + where + stage1 = do + ddeps <- liftIO $ diagnoseDeployments ds + let dcrs = checkDeployments ddeps + -- Check for impossible deployments + when (any impossibleDeployment dcrs) $ + err (zip ddeps dcrs) "Deployment is impossible." + -- Clean up the situation + forM_ dcrs $ \d -> do + case d of + DirtySituation _ _ cis -> performClean cis + _ -> return () + stage2 + -- Check again + = do + ddeps2 <- liftIO $ diagnoseDeployments ds + let dcrs2 = checkDeployments ddeps2 + -- Error if the cleaning is not done now. + when (any (\d -> impossibleDeployment d || dirtyDeployment d) dcrs2) $ + err (zip ddeps2 dcrs2) $ + unlines + [ "Situation was not entirely clean after attemted cleanup." + , "Maybe you forgot to enable cleanups (--replace-all)?" + ] + -- Perform deployments + liftIO $ + mapM_ performDeployment $ + map (\(ReadyToDeploy i) -> i) $ filter deploymentReadyToDeploy dcrs2 + stage3 + -- Check one last time. + = do + do ddeps3 <- liftIO $ diagnoseDeployments ds + let dcrsf3 = checkDeployments ddeps3 + when (any (not . deploymentIsDone) dcrsf3) $ do + err + (zip ddeps3 dcrsf3) + "Something went wrong during deployment. It's not done yet." + err :: [(DiagnosedDeployment, DeploymentCheckResult)] + -> String + -> SparkDeployer () + err dcrs_ text = do + liftIO $ putStrLn $ formatDeploymentChecks dcrs_ + throwError $ DeployError text diff --git a/src/SuperUserSpark/Deployer/Internal.hs b/src/SuperUserSpark/Deployer/Internal.hs new file mode 100644 --- /dev/null +++ b/src/SuperUserSpark/Deployer/Internal.hs @@ -0,0 +1,61 @@ +module SuperUserSpark.Deployer.Internal where + +import Import hiding (()) + +import Data.Text (pack) +import System.FilePath.Posix + (dropFileName, dropTrailingPathSeparator) +import System.Posix.Files (createSymbolicLink, removeLink) + +import SuperUserSpark.Bake.Types +import SuperUserSpark.Check.Types +import SuperUserSpark.CoreTypes +import SuperUserSpark.Deployer.Types +import SuperUserSpark.Utils + +performClean :: CleanupInstruction -> SparkDeployer () +performClean (CleanFile fp) = incase deploySetsReplaceFiles $ rmFile fp +performClean (CleanDirectory fp) = + incase deploySetsReplaceDirectories $ rmDir fp +performClean (CleanLink fp) = incase deploySetsReplaceLinks $ unlink fp + +unlink :: Path Abs File -> SparkDeployer () +unlink = liftIO . removeLink . dropTrailingPathSeparator . toFilePath + +rmFile :: Path Abs File -> SparkDeployer () +rmFile = liftIO . removeFile + +rmDir :: Path Abs Dir -> SparkDeployer () +rmDir = liftIO . removeDirRecur + +performDeployment :: Instruction -> IO () +performDeployment (CopyFile source destination) = + performCopyFile source destination +performDeployment (CopyDir source destination) = + performCopyDir source destination +performDeployment (LinkFile source destination) = + performLinkFile source destination +performDeployment (LinkDir source destination) = + performLinkDir source destination + +performCopyFile :: Path Abs File -> Path Abs File -> IO () +performCopyFile src dst = do + ensureDir $ parent dst + copyFile src dst + +performCopyDir :: Path Abs Dir -> Path Abs Dir -> IO () +performCopyDir src dst = do + ensureDir $ parent dst + copyDirRecur src dst + +performLinkFile :: Path Abs File -> Path Abs File -> IO () +performLinkFile src dst = do + ensureDir $ parent dst + createSymbolicLink (toFilePath src) (toFilePath dst) + +performLinkDir :: Path Abs Dir -> Path Abs Dir -> IO () +performLinkDir src dst = do + ensureDir $ parent dst + createSymbolicLink + (dropTrailingPathSeparator $ toFilePath src) + (dropTrailingPathSeparator $ toFilePath dst) diff --git a/src/SuperUserSpark/Deployer/Types.hs b/src/SuperUserSpark/Deployer/Types.hs new file mode 100644 --- /dev/null +++ b/src/SuperUserSpark/Deployer/Types.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE DeriveGeneric #-} + +module SuperUserSpark.Deployer.Types where + +import Import + +import SuperUserSpark.Bake.Types +import SuperUserSpark.Check.Types +import SuperUserSpark.CoreTypes + +data DeployAssignment = DeployAssignment + { deployCardReference :: BakeCardReference + , deploySettings :: DeploySettings + } deriving (Show, Eq, Generic) + +instance Validity DeployAssignment + +data DeploySettings = DeploySettings + { deploySetsReplaceLinks :: Bool + , deploySetsReplaceFiles :: Bool + , deploySetsReplaceDirectories :: Bool + , deployCheckSettings :: CheckSettings + } deriving (Show, Eq, Generic) + +instance Validity DeploySettings + +defaultDeploySettings :: DeploySettings +defaultDeploySettings = + DeploySettings + { deploySetsReplaceLinks = False + , deploySetsReplaceFiles = False + , deploySetsReplaceDirectories = False + , deployCheckSettings = defaultCheckSettings + } + +type SparkDeployer = ExceptT DeployError (ReaderT DeploySettings IO) + +data DeployError + = DeployCheckError CheckError + | DeployError String + deriving (Show, Eq, Generic) + +instance Validity DeployError + +data PreDeployment + = Ready FilePath + FilePath + DeploymentKind + | AlreadyDone + | Error String + deriving (Show, Eq, Generic) + +instance Validity PreDeployment diff --git a/src/SuperUserSpark/Diagnose.hs b/src/SuperUserSpark/Diagnose.hs new file mode 100644 --- /dev/null +++ b/src/SuperUserSpark/Diagnose.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE RecordWildCards #-} + +{- + The responsibility of the diagnoser is to turn baked deployments into + diagnosed deployments. This is purely a read-only operation that looks + at the current state of the file system. +-} +module SuperUserSpark.Diagnose + ( diagnoseFromArgs + , diagnoseAssignment + , deriveDiagnoseSettings + , diagnose + , formatDiagnoseError + , diagnoserBake + , diagnoseDeployments + ) where + +import Import + +import qualified Data.Aeson.Encode.Pretty as JSON + +import SuperUserSpark.Bake +import SuperUserSpark.Bake.Internal +import SuperUserSpark.Bake.Types +import SuperUserSpark.Diagnose.Internal +import SuperUserSpark.Diagnose.Types +import SuperUserSpark.OptParse.Types +import SuperUserSpark.Utils + +diagnoseFromArgs :: DiagnoseArgs -> IO () +diagnoseFromArgs cas = do + errOrAss <- diagnoseAssignment cas + case errOrAss of + Left err -> die $ unwords ["Failed to build Diagnose assignment:", err] + Right ass -> diagnose ass + +diagnoseAssignment :: DiagnoseArgs -> IO (Either String DiagnoseAssignment) +diagnoseAssignment DiagnoseArgs {..} = do + errOrCardRef <- parseBakeCardReference diagnoseArgCardRef + case errOrCardRef of + Left err -> pure $ Left err + Right cardRef -> + DiagnoseAssignment cardRef <$$> + deriveDiagnoseSettings cardRef diagnoseFlags + +deriveDiagnoseSettings :: BakeCardReference + -> DiagnoseFlags + -> IO (Either String DiagnoseSettings) +deriveDiagnoseSettings bcr DiagnoseFlags {..} = + DiagnoseSettings <$$> deriveBakeSettings bcr diagnoseBakeFlags + +diagnose :: DiagnoseAssignment -> IO () +diagnose DiagnoseAssignment {..} = do + errOrDone <- + runReaderT + (runExceptT $ diagnoseByCardRef diagnoseCardReference) + diagnoseSettings + case errOrDone of + Left err -> die $ formatDiagnoseError err + Right () -> pure () + +formatDiagnoseError :: DiagnoseError -> String +formatDiagnoseError (DiagnoseBakeError ce) = formatBakeError ce +formatDiagnoseError (DiagnoseError s) = unwords ["Diagnose failed:", s] + +diagnoseByCardRef :: BakeCardReference -> SparkDiagnoser () +diagnoseByCardRef checkCardReference = do + deps <- + diagnoserBake $ + compileBakeCardRef checkCardReference >>= bakeDeployments + ddeps <- liftIO $ diagnoseDeployments deps + putStrLn $ JSON.encodePretty ddeps + +diagnoserBake :: SparkBaker a -> SparkDiagnoser a +diagnoserBake = + withExceptT DiagnoseBakeError . + mapExceptT (withReaderT diagnoseBakeSettings) + +diagnoseDeployments :: [BakedDeployment] -> IO [DiagnosedDeployment] +diagnoseDeployments = mapM diagnoseDeployment diff --git a/src/SuperUserSpark/Diagnose/Internal.hs b/src/SuperUserSpark/Diagnose/Internal.hs new file mode 100644 --- /dev/null +++ b/src/SuperUserSpark/Diagnose/Internal.hs @@ -0,0 +1,77 @@ +module SuperUserSpark.Diagnose.Internal where + +import Import + +import qualified Data.ByteString as SB +import Data.Hashable +import System.Posix.Files + (getSymbolicLinkStatus, isBlockDevice, isCharacterDevice, + isDirectory, isNamedPipe, isRegularFile, isSocket, isSymbolicLink, + readSymbolicLink) + +import SuperUserSpark.Bake.Types +import SuperUserSpark.Compiler.Types +import SuperUserSpark.Diagnose.Types + +diagnoseDeployment :: BakedDeployment -> IO DiagnosedDeployment +diagnoseDeployment (Deployment bds kind) = do + ddirs <- diagnoseDirs bds + return $ Deployment ddirs kind + +diagnoseDirs :: DeploymentDirections AbsP + -> IO (DeploymentDirections DiagnosedFp) +diagnoseDirs (Directions srcs dst) = + Directions <$> mapM diagnoseAbsP srcs <*> diagnoseAbsP dst + +diagnoseAbsP :: AbsP -> IO DiagnosedFp +diagnoseAbsP fp = do + d <- diagnoseFp fp + hash_ <- hashFilePath fp + return $ D fp d hash_ + +diagnoseFp :: AbsP -> IO Diagnostics +diagnoseFp absp = do + let fp = toPath absp + ms <- forgivingAbsence $ getSymbolicLinkStatus fp + case ms of + Nothing -> pure Nonexistent + Just s -> + if isBlockDevice s || + isCharacterDevice s || isSocket s || isNamedPipe s + then return IsWeird + else do + if isSymbolicLink s + then do + point <- readSymbolicLink fp + -- TODO check what happens with relative links. + apoint <- AbsP <$> parseAbsFile point + return $ IsLinkTo apoint + else pure $ + if isDirectory s + then IsDirectory + else if isRegularFile s + then IsFile + else IsWeird + +-- | Hash a filepath so that two filepaths with the same contents have the same hash +hashFilePath :: AbsP -> IO HashDigest +hashFilePath fp = do + d <- diagnoseFp fp + case d of + IsFile -> hashFile fp + IsDirectory -> hashDirectory fp + IsLinkTo _ -> return $ HashDigest $ hash () + IsWeird -> return $ HashDigest $ hash () + Nonexistent -> return $ HashDigest $ hash () + +hashFile :: AbsP -> IO HashDigest +hashFile fp = (HashDigest . hash) <$> SB.readFile (toPath fp) + +hashDirectory :: AbsP -> IO HashDigest +hashDirectory fp = do + tdir <- parseAbsDir (toPath fp) + walkDirAccum Nothing writer_ tdir + where + writer_ _ _ files = do + hashes <- mapM (hashFile . AbsP) files + pure $ HashDigest $ hash hashes diff --git a/src/SuperUserSpark/Diagnose/Types.hs b/src/SuperUserSpark/Diagnose/Types.hs new file mode 100644 --- /dev/null +++ b/src/SuperUserSpark/Diagnose/Types.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module SuperUserSpark.Diagnose.Types where + +import Import + +import Data.Aeson +import Data.Hashable +import Text.Printf + +import SuperUserSpark.Bake.Types +import SuperUserSpark.Compiler.Types + +data DiagnoseAssignment = DiagnoseAssignment + { diagnoseCardReference :: BakeCardReference + , diagnoseSettings :: DiagnoseSettings + } deriving (Show, Eq, Generic) + +instance Validity DiagnoseAssignment + +data DiagnoseSettings = DiagnoseSettings + { diagnoseBakeSettings :: BakeSettings + } deriving (Show, Eq, Generic) + +instance Validity DiagnoseSettings + +defaultDiagnoseSettings :: DiagnoseSettings +defaultDiagnoseSettings = + DiagnoseSettings {diagnoseBakeSettings = defaultBakeSettings} + +type SparkDiagnoser = ExceptT DiagnoseError (ReaderT DiagnoseSettings IO) + +data DiagnoseError + = DiagnoseBakeError BakeError + | DiagnoseError String + deriving (Show, Eq, Generic) + +instance Validity DiagnoseError + +newtype HashDigest = + HashDigest Int + deriving (Show, Eq, Generic) + +instance Validity HashDigest + +instance Monoid HashDigest where + mempty = HashDigest (hash ()) + (HashDigest h1) `mappend` (HashDigest h2) = HashDigest $ h1 * 31 + h2 + +instance Hashable HashDigest + +instance ToJSON HashDigest where + toJSON (HashDigest i) = toJSON $ (printf "%016x" i :: String) + +data Diagnostics + = Nonexistent + | IsFile + | IsDirectory + | IsLinkTo AbsP -- Could point to directory too. + | IsWeird + deriving (Show, Eq, Generic) + +instance Validity Diagnostics + +instance ToJSON Diagnostics where + toJSON Nonexistent = String "nonexistent" + toJSON IsFile = String "file" + toJSON IsDirectory = String "directory" + toJSON (IsLinkTo ap) = + object ["kind" .= String "link", "link destination" .= ap] + toJSON IsWeird = String "weird" + +data DiagnosedFp = D + { diagnosedFilePath :: AbsP + , diagnosedDiagnostics :: Diagnostics + , diagnosedHashDigest :: HashDigest + } deriving (Show, Eq, Generic) + +instance Validity DiagnosedFp + +instance ToJSON DiagnosedFp where + toJSON D {..} = + object $ + ["path" .= diagnosedFilePath, "diagnostics" .= diagnosedDiagnostics] ++ + if diagnosedHashDigest == mempty + then [] + else ["hash" .= diagnosedHashDigest] + +type DiagnosedDeployment = Deployment DiagnosedFp diff --git a/src/SuperUserSpark/Language/Types.hs b/src/SuperUserSpark/Language/Types.hs new file mode 100644 --- /dev/null +++ b/src/SuperUserSpark/Language/Types.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE DeriveGeneric #-} + +module SuperUserSpark.Language.Types where + +import Import + +import SuperUserSpark.CoreTypes + +-- * Cards +type CardName = String + +type Source = FilePath + +type Destination = FilePath + +data Card = Card + { cardName :: CardName + , cardContent :: Declaration + } deriving (Show, Eq, Generic) + +instance Validity Card + +-- ** 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, Generic) + +instance Validity Declaration + +-- * Card references +-- | Reference a card by name (inside a file) +newtype CardNameReference = + CardNameReference CardName + deriving (Show, Eq, Generic) + +instance Validity CardNameReference + +-- | 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, Generic) + +instance Validity CardFileReference + +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, Generic) + +instance Validity CardReference + +-- * Card files +data SparkFile = SparkFile + { sparkFilePath :: Path Abs File + , sparkFileCards :: [Card] + } deriving (Show, Eq, Generic) + +instance Validity SparkFile diff --git a/src/SuperUserSpark/OptParse.hs b/src/SuperUserSpark/OptParse.hs new file mode 100644 --- /dev/null +++ b/src/SuperUserSpark/OptParse.hs @@ -0,0 +1,187 @@ +module SuperUserSpark.OptParse + ( getDispatch + , Dispatch(..) + ) where + +import Import + +import Options.Applicative +import System.Environment (getArgs) + +import SuperUserSpark.OptParse.Types + +getDispatch :: IO Dispatch +getDispatch = do + args <- getArgs + let result = runOptionsParser args + handleParseResult result + +runOptionsParser :: [String] -> ParserResult Dispatch +runOptionsParser strs = execParserPure prefs_ optionsParser strs + where + prefs_ = + ParserPrefs + { prefMultiSuffix = "" + , prefDisambiguate = True + , prefShowHelpOnError = True + , prefShowHelpOnEmpty = True + , prefBacktrack = True + , prefColumns = 80 + } + +optionsParser :: ParserInfo Dispatch +optionsParser = + info + (helper <*> parseDispatch) + (fullDesc <> progDesc "Super User Spark, author: Tom Sydney Kerckhove") + +parseDispatch :: Parser Dispatch +parseDispatch = + hsubparser $ + mconcat + [ command "parse" parseParse + , command "compile" parseCompile + , command "bake" parseBake + , command "diagnose" parseDiagnose + , command "check" parseCheck + , command "deploy" parseDeploy + ] + +parseParse :: ParserInfo Dispatch +parseParse = info parser modifier + where + parser = DispatchParse <$> parseParseArgs + modifier = + fullDesc <> + progDesc "Parse a spark file and check for syntactic errors." + +parseParseArgs :: Parser ParseArgs +parseParseArgs = + ParseArgs <$> + strArgument (mconcat [metavar "FILE", help "the file to parse"]) + +parseCompile :: ParserInfo Dispatch +parseCompile = info parser modifier + where + parser = DispatchCompile <$> parseCompileArgs + modifier = fullDesc <> progDesc "Compile a spark card." + +parseCompileArgs :: Parser CompileArgs +parseCompileArgs = + CompileArgs <$> + strArgument (metavar "CARDREF" <> help "the card file to compile") <*> + option + (Just <$> str) + (mconcat + [ long "output" + , short 'o' + , value Nothing + , metavar "FILE" + , help "The output file for compilation" + ]) <*> + parseCompileFlags + +parseCompileFlags :: Parser CompileFlags +parseCompileFlags = + CompileFlags <$> + option + (Just <$> str) + (mconcat + [ long "kind" + , short 'k' + , value Nothing + , metavar "KIND" + , help + "The kind specification for unspecified deployments (default: link)" + ]) <*> + option + (Just <$> str) + (mconcat + [ long "override" + , short 'O' + , value Nothing + , metavar "KIND" + , help "Override every deployment to be of the given kind" + ]) + +parseBake :: ParserInfo Dispatch +parseBake = info parser modifier + where + parser = DispatchBake <$> parseBakeArgs + modifier = fullDesc <> progDesc "Bake the raw deployment of a spark card." + +parseBakeArgs :: Parser BakeArgs +parseBakeArgs = + BakeArgs <$> strArgument (metavar "CARDREF" <> help "the card to bake") <*> + parseBakeFlags + +parseBakeFlags :: Parser BakeFlags +parseBakeFlags = BakeFlags <$> parseCompileFlags + +parseDiagnose :: ParserInfo Dispatch +parseDiagnose = info parser modifier + where + parser = DispatchDiagnose <$> parseDiagnoseArgs + modifier = + fullDesc <> progDesc "Diagnose the baked deployment of a spark card." + +parseDiagnoseArgs :: Parser DiagnoseArgs +parseDiagnoseArgs = + DiagnoseArgs <$> + strArgument (metavar "CARDREF" <> help "the card to diagnose") <*> + parseDiagnoseFlags + +parseDiagnoseFlags :: Parser DiagnoseFlags +parseDiagnoseFlags = DiagnoseFlags <$> parseBakeFlags + +parseCheck :: ParserInfo Dispatch +parseCheck = info parser modifier + where + parser = DispatchCheck <$> parseCheckArgs + modifier = fullDesc <> progDesc "Check the deployment of a spark card." + +parseCheckArgs :: Parser CheckArgs +parseCheckArgs = + CheckArgs <$> strArgument (metavar "CARDREF" <> help "the card to check") <*> + parseCheckFlags + +parseCheckFlags :: Parser CheckFlags +parseCheckFlags = CheckFlags <$> parseDiagnoseFlags + +parseDeploy :: ParserInfo Dispatch +parseDeploy = info parser modifier + where + parser = DispatchDeploy <$> parseDeployArgs + modifier = fullDesc <> progDesc "Deploy a spark card." + +parseDeployArgs :: Parser DeployArgs +parseDeployArgs = + DeployArgs <$> strArgument (metavar "CARDREF" <> help "the card to deploy") <*> + parseDeployFlags + +parseDeployFlags :: Parser DeployFlags +parseDeployFlags = + DeployFlags <$> + switch + (mconcat + [ long "replace-links" + , help "Replace links at deploy destinations." + ]) <*> + switch + (mconcat + [ long "replace-files" + , help "Replace existing files at deploy destinations." + ]) <*> + switch + (mconcat + [ long "replace-Directories" + , help "Replace existing directories at deploy destinations." + ]) <*> + switch + (mconcat + [ long "replace-all" + , short 'r' + , help + "Equivalent to --replace-files --replace-directories --replace-links" + ]) <*> + parseCheckFlags diff --git a/src/SuperUserSpark/OptParse/Types.hs b/src/SuperUserSpark/OptParse/Types.hs new file mode 100644 --- /dev/null +++ b/src/SuperUserSpark/OptParse/Types.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE DeriveGeneric #-} + +module SuperUserSpark.OptParse.Types where + +import Import + +data Dispatch + = DispatchParse ParseArgs + | DispatchCompile CompileArgs + | DispatchBake BakeArgs + | DispatchDiagnose DiagnoseArgs + | DispatchCheck CheckArgs + | DispatchDeploy DeployArgs + deriving (Show, Eq, Generic) + +instance Validity Dispatch + +data ParseArgs = ParseArgs + { parseFilePath :: FilePath + } deriving (Show, Eq, Generic) + +instance Validity ParseArgs + +data CompileArgs = CompileArgs + { compileArgCardRef :: String + , compileArgOutput :: Maybe FilePath + , compileFlags :: CompileFlags + } deriving (Show, Eq, Generic) + +instance Validity CompileArgs + +data CompileFlags = CompileFlags + { compileDefaultKind :: Maybe String + , compileKindOverride :: Maybe String + } deriving (Show, Eq, Generic) + +instance Validity CompileFlags + +data BakeArgs = BakeArgs + { bakeCardRef :: String + , bakeFlags :: BakeFlags + } deriving (Show, Eq, Generic) + +instance Validity BakeArgs + +data BakeFlags = BakeFlags + { bakeCompileFlags :: CompileFlags + } deriving (Show, Eq, Generic) + +instance Validity BakeFlags + +data DiagnoseArgs = DiagnoseArgs + { diagnoseArgCardRef :: String + , diagnoseFlags :: DiagnoseFlags + } deriving (Show, Eq, Generic) + +instance Validity DiagnoseArgs + +data DiagnoseFlags = DiagnoseFlags + { diagnoseBakeFlags :: BakeFlags + } deriving (Show, Eq, Generic) + +instance Validity DiagnoseFlags + +data CheckArgs = CheckArgs + { checkArgCardRef :: String + , checkFlags :: CheckFlags + } deriving (Show, Eq, Generic) + +instance Validity CheckArgs + +data CheckFlags = CheckFlags + { checkDiagnoseFlags ::DiagnoseFlags + } deriving (Show, Eq, Generic) + +instance Validity CheckFlags + +data DeployArgs = DeployArgs + { deployArgCardRef :: String + , deployFlags :: DeployFlags + } deriving (Show, Eq, Generic) + +instance Validity DeployArgs + +data DeployFlags = DeployFlags + { deployFlagReplaceLinks :: Bool + , deployFlagReplaceFiles :: Bool + , deployFlagReplaceDirectories :: Bool + , deployFlagReplaceAll :: Bool + , deployCheckFlags :: CheckFlags + } deriving (Show, Eq, Generic) + +instance Validity DeployFlags diff --git a/src/SuperUserSpark/Parser.hs b/src/SuperUserSpark/Parser.hs new file mode 100644 --- /dev/null +++ b/src/SuperUserSpark/Parser.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE RecordWildCards #-} + +{- + The Parser is responsible for transforming a 'String' into an AST. +-} +module SuperUserSpark.Parser where + +import Import + +import Control.Exception (try) + +import SuperUserSpark.Language.Types +import SuperUserSpark.OptParse.Types +import SuperUserSpark.Parser.Internal +import SuperUserSpark.Parser.Types +import SuperUserSpark.Utils + +parseFromArgs :: ParseArgs -> IO () +parseFromArgs pa = do + errOrAss <- parseAssignment pa + case errOrAss of + Left err -> die $ unwords ["Unable to build parse assignment:", err] + Right ass -> parse ass + +parseAssignment :: ParseArgs -> IO (Either String ParseAssignment) +parseAssignment ParseArgs {..} = + ParseAssignment <$$> + ((left (show :: PathParseException -> String)) <$> + try (resolveFile' parseFilePath)) + +parse :: ParseAssignment -> IO () +parse ParseAssignment {..} = do + errOrFile <- parseFile fileToParse + case errOrFile of + Left err -> die $ formatParseError err + Right _ -> pure () + +formatParseError :: ParseError -> String +formatParseError (ParseError pe) = show pe + +parseFile :: Path Abs File -> IO (Either ParseError SparkFile) +parseFile file = (left ParseError . parseCardFile file) <$> readFile file diff --git a/src/SuperUserSpark/Parser/Internal.hs b/src/SuperUserSpark/Parser/Internal.hs new file mode 100644 --- /dev/null +++ b/src/SuperUserSpark/Parser/Internal.hs @@ -0,0 +1,267 @@ +module SuperUserSpark.Parser.Internal where + +import Import + +import Data.List (isSuffixOf) +import SuperUserSpark.Constants +import SuperUserSpark.CoreTypes +import SuperUserSpark.Language.Types +import Text.Parsec +import Text.Parsec.String + +parseCardFile :: Path Abs File -> String -> Either ParseError SparkFile +parseCardFile f s = do + cs <- parseFromSource sparkFile f s + return $ SparkFile f cs + +parseFromSource :: Parser a -> Path Abs File -> String -> Either ParseError a +parseFromSource parser file = parse parser $ toFilePath file + +--[ 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 + +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 () diff --git a/src/SuperUserSpark/Parser/Types.hs b/src/SuperUserSpark/Parser/Types.hs new file mode 100644 --- /dev/null +++ b/src/SuperUserSpark/Parser/Types.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} + +module SuperUserSpark.Parser.Types where + +import Import + +import qualified Text.Parsec as Parsec + +data ParseAssignment = ParseAssignment + { fileToParse :: Path Abs File + } deriving (Show, Eq, Generic) + +instance Validity ParseAssignment + +data ParseSettings = + ParseSettings + deriving (Show, Eq, Generic) + +instance Validity ParseSettings + +newtype ParseError = + ParseError Parsec.ParseError + deriving (Show, Eq, Generic) + +instance Validity ParseError where + isValid (ParseError _) = True diff --git a/src/SuperUserSpark/PreCompiler.hs b/src/SuperUserSpark/PreCompiler.hs new file mode 100644 --- /dev/null +++ b/src/SuperUserSpark/PreCompiler.hs @@ -0,0 +1,58 @@ +module SuperUserSpark.PreCompiler where + +import Import + +import SuperUserSpark.Language.Types +import SuperUserSpark.PreCompiler.Types +import SuperUserSpark.Utils + +preCompileChecks :: Card -> [PreCompileError] +preCompileChecks c = runIdentity $ execWriterT $ cleanCard c + +dirty :: String -> Precompiler () +dirty s = tell [PreCompileError $ "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 () diff --git a/src/SuperUserSpark/PreCompiler/Types.hs b/src/SuperUserSpark/PreCompiler/Types.hs new file mode 100644 --- /dev/null +++ b/src/SuperUserSpark/PreCompiler/Types.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE DeriveGeneric #-} + +module SuperUserSpark.PreCompiler.Types where + +import Import + +newtype PreCompileError = + PreCompileError String + deriving (Show, Eq, Generic) + +instance Validity PreCompileError + +type Precompiler = WriterT [PreCompileError] Identity diff --git a/src/SuperUserSpark/Utils.hs b/src/SuperUserSpark/Utils.hs new file mode 100644 --- /dev/null +++ b/src/SuperUserSpark/Utils.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module SuperUserSpark.Utils where + +import Import + +import Data.List (isInfixOf) +import qualified System.Directory as D (createDirectoryIfMissing) + +incase + :: MonadReader c m + => (c -> Bool) -> m () -> m () +incase bf func = do + b <- asks bf + when b func + +incaseElse + :: MonadReader c m + => (c -> Bool) -> m a -> m a -> m a +incaseElse bf funcif funcelse = do + b <- asks bf + if b + then funcif + else funcelse + +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 -> b) -> IO (Either e a) -> IO (Either e b) +(<$$>) f fa = do + a <- fa + pure $ f <$> a + +(<**>) :: IO (Either e (a -> b)) -> IO (Either e a) -> IO (Either e b) +(<**>) fa fb = do + e1 <- fa + e2 <- fb + pure $ e1 <*> e2 diff --git a/src/Types.hs b/src/Types.hs deleted file mode 100644 --- a/src/Types.hs +++ /dev/null @@ -1,49 +0,0 @@ -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.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 (MonadWriter (..), WriterT, execWriterT, - runWriterT, tell) -import Debug.Trace - -import Text.Parsec (ParseError) - -import Config.Types -import CoreTypes -import Monad - ----[ Options ]--- -data GlobalOptions = GlobalOptions - { opt_output :: Maybe FilePath - , 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) diff --git a/src/Utils.hs b/src/Utils.hs deleted file mode 100644 --- a/src/Utils.hs +++ /dev/null @@ -1,44 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -module Utils where - -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 - -debug :: (MonadReader SparkConfig m, MonadIO m) => String -> m () -debug str = incase (asks conf_debug) $ liftIO $ putStrLn str - -incase :: MonadReader SparkConfig m => (SparkConfig -> Bool) -> m () -> m () -incase bf func = do - b <- asks bf - when b func - -incaseElse :: MonadReader SparkConfig m => (SparkConfig -> Bool) -> m a -> m a -> m a -incaseElse bf funcif funcelse = do - b <- asks bf - if b - then funcif - else funcelse - -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 - diff --git a/super-user-spark.cabal b/super-user-spark.cabal --- a/super-user-spark.cabal +++ b/super-user-spark.cabal @@ -1,5 +1,5 @@ name: super-user-spark -version: 0.3.2.0 +version: 0.4.0.0 license: MIT license-file: LICENSE description: Configure your dotfile deployment with a DSL. @@ -14,32 +14,36 @@ library hs-source-dirs: src 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 - , Language.Types - , Monad - , Parser - , Parser.Internal - , PreCompiler - , Seed - , Spark - , Types - , Utils + SuperUserSpark + , SuperUserSpark.Bake + , SuperUserSpark.Bake.Internal + , SuperUserSpark.Bake.Types + , SuperUserSpark.Check + , SuperUserSpark.Check.Internal + , SuperUserSpark.Check.Types + , SuperUserSpark.Compiler + , SuperUserSpark.Compiler.Internal + , SuperUserSpark.Compiler.Types + , SuperUserSpark.Compiler.Utils + , SuperUserSpark.Constants + , SuperUserSpark.CoreTypes + , SuperUserSpark.Deployer + , SuperUserSpark.Deployer.Internal + , SuperUserSpark.Deployer.Types + , SuperUserSpark.Diagnose + , SuperUserSpark.Diagnose.Internal + , SuperUserSpark.Diagnose.Types + , SuperUserSpark.Language.Types + , SuperUserSpark.OptParse + , SuperUserSpark.OptParse.Types + , SuperUserSpark.Parser + , SuperUserSpark.Parser.Internal + , SuperUserSpark.Parser.Types + , SuperUserSpark.PreCompiler + , SuperUserSpark.PreCompiler.Types + , SuperUserSpark.Utils + other-modules: + Import ghc-options: -Wall @@ -49,24 +53,28 @@ -fno-warn-name-shadowing build-depends: - base >= 4.6 && < 5 - , aeson >= 0.8 && < 1.1 - , aeson-pretty >= 0.7 && < 0.9 + base >= 4.9 && < 5 + , aeson >= 0.11 && < 1.2 + , aeson-pretty >= 0.8 && < 0.9 , bytestring >= 0.10 && < 0.11 - , directory >= 1.2.5 && < 1.3 + , directory >= 1.3 && < 1.4 , filepath >= 1.4 && < 1.5 , mtl >= 2.2 && < 2.3 - , optparse-applicative >= 0.11 && < 0.14 + , optparse-applicative >= 0.13 && < 0.14 , parsec >= 3.1.9 && < 3.2 - , process >= 1.2 && < 1.5 - , pureMD5 >= 2.1 && < 2.2 - , shelly >= 1.6 && < 1.7 + , process >= 1.4 && < 1.6 + , hashable >= 1.2 && < 1.3 , text >= 1.2 && < 1.3 - , transformers >= 0.4 && < 0.6 , unix >= 2.7 && < 2.8 + , validity >= 0.3.2 && < 0.4 + , validity-path >= 0.1 && < 0.2 + , path >= 0.5 && < 0.6 + , path-io >= 1.2 && < 1.3 + , iostring >= 0.0 && < 0.1 default-language: Haskell2010 + default-extensions: NoImplicitPrelude -executable spark +executable super-user-spark main-is: Main.hs hs-source-dirs: app ghc-options: -Wall @@ -76,7 +84,7 @@ -fno-warn-name-shadowing -threaded -rtsopts -with-rtsopts=-N build-depends: - base >= 4.6 && < 5 + base >= 4.9 && < 5 , super-user-spark default-language: Haskell2010 @@ -86,17 +94,34 @@ main-is: MainTest.hs hs-source-dirs: test other-modules: - CheckSpec - , ParserSpec - , CompilerSpec - , DeployerSpec - , SeedSpec - , EndToEndSpec + SuperUserSpark.BakeSpec + , SuperUserSpark.Bake.Gen + , SuperUserSpark.Check.Gen + , SuperUserSpark.Check.TestUtils + , SuperUserSpark.CheckSpec + , SuperUserSpark.Compiler.Gen + , SuperUserSpark.Compiler.TestUtils + , SuperUserSpark.CompilerSpec + , SuperUserSpark.Deployer.Gen + , SuperUserSpark.DeployerSpec + , SuperUserSpark.Diagnose.Gen + , SuperUserSpark.Diagnose.TestUtils + , SuperUserSpark.DiagnoseSpec + , SuperUserSpark.EndToEnd.RegressionSpec + , SuperUserSpark.EndToEndSpec + , SuperUserSpark.Language.Gen + , SuperUserSpark.OptParse.Gen + , SuperUserSpark.Parser.Gen + , SuperUserSpark.Parser.TestUtils + , SuperUserSpark.ParserSpec + , SuperUserSpark.PreCompiler.Gen + , TestImport + , TestUtils build-depends: - base >= 4.6 && < 5 + base >= 4.9 && < 5 , super-user-spark - , hspec >= 2.2 && < 2.4 - , hspec-core >= 2.2 && < 2.4 + , hspec >= 2.2 && < 2.5 + , hspec-core >= 2.2 && < 2.5 , HUnit >= 1.2 && < 1.6 , QuickCheck >= 2.8 && < 2.10 , aeson @@ -108,10 +133,19 @@ , optparse-applicative , parsec , process - , pureMD5 - , shelly , text , transformers , unix + , genvalidity >= 0.3.1 && < 0.4 + , genvalidity-path >= 0.1 && < 0.2 + , genvalidity-hspec >= 0.3.1 && < 0.4 + , genvalidity-hspec-aeson >= 0.0 && < 0.1 + , validity + , validity-path + , path + , path-io + , iostring + , hashable default-language: Haskell2010 + default-extensions: NoImplicitPrelude diff --git a/test/CheckSpec.hs b/test/CheckSpec.hs deleted file mode 100644 --- a/test/CheckSpec.hs +++ /dev/null @@ -1,298 +0,0 @@ -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 - - diff --git a/test/CompilerSpec.hs b/test/CompilerSpec.hs deleted file mode 100644 --- a/test/CompilerSpec.hs +++ /dev/null @@ -1,364 +0,0 @@ -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 - 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 <- runDefaultSparker $ 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 - diff --git a/test/DeployerSpec.hs b/test/DeployerSpec.hs deleted file mode 100644 --- a/test/DeployerSpec.hs +++ /dev/null @@ -1,263 +0,0 @@ -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 - - diff --git a/test/EndToEndSpec.hs b/test/EndToEndSpec.hs deleted file mode 100644 --- a/test/EndToEndSpec.hs +++ /dev/null @@ -1,82 +0,0 @@ -module EndToEndSpec (spec) where - -import Spark -import System.Directory hiding (createDirectoryIfMissing) -import System.Environment (withArgs) -import System.Exit (ExitCode (ExitSuccess)) -import System.FilePath.Posix (()) -import System.Posix.Files -import Test.Hspec -import Utils - -spec :: Spec -spec = do - helpTextSpec - regularWorkflowSpec - -helpTextSpec :: Spec -helpTextSpec = describe "help text test" $ do - it "shows the help text without crashing" $ do - withArgs ["--help"] spark `shouldThrow` (== ExitSuccess) - -regularWorkflowSpec :: Spec -regularWorkflowSpec = 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 - - diff --git a/test/MainTest.hs b/test/MainTest.hs --- a/test/MainTest.hs +++ b/test/MainTest.hs @@ -1,11 +1,10 @@ {-# OPTIONS_GHC -F -pgmF hspec-discover #-} + module MainTest where import qualified Spec -import Test.Hspec.Formatters -import Test.Hspec.Runner +import Test.Hspec.Formatters +import Test.Hspec.Runner main :: IO () main = hspecWith defaultConfig {configFormatter = Just progress} Spec.spec - - diff --git a/test/ParserSpec.hs b/test/ParserSpec.hs deleted file mode 100644 --- a/test/ParserSpec.hs +++ /dev/null @@ -1,498 +0,0 @@ -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 diff --git a/test/SeedSpec.hs b/test/SeedSpec.hs deleted file mode 100644 --- a/test/SeedSpec.hs +++ /dev/null @@ -1,24 +0,0 @@ -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 diff --git a/test/SuperUserSpark/Bake/Gen.hs b/test/SuperUserSpark/Bake/Gen.hs new file mode 100644 --- /dev/null +++ b/test/SuperUserSpark/Bake/Gen.hs @@ -0,0 +1,34 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module SuperUserSpark.Bake.Gen where + +import TestImport + +import SuperUserSpark.Bake.Types +import SuperUserSpark.Compiler.Gen () + +instance GenUnchecked BakeAssignment + +instance GenValid BakeAssignment where + genValid = BakeAssignment <$> genValid <*> genValid + +instance GenUnchecked BakeCardReference + +instance GenValid BakeCardReference + +instance GenUnchecked BakeSettings + +instance GenValid BakeSettings where + genValid = BakeSettings <$> genValid <*> genValid <*> genValid + +instance GenUnchecked BakeError + +instance GenValid BakeError + +instance GenUnchecked AbsP + +instance GenValid AbsP + +instance GenUnchecked ID + +instance GenValid ID diff --git a/test/SuperUserSpark/BakeSpec.hs b/test/SuperUserSpark/BakeSpec.hs new file mode 100644 --- /dev/null +++ b/test/SuperUserSpark/BakeSpec.hs @@ -0,0 +1,172 @@ +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TemplateHaskell #-} + +module SuperUserSpark.BakeSpec where + +import TestImport + +import Data.Either (isLeft) +import Data.Maybe (isNothing) + +import qualified System.FilePath as FP +import System.Posix.Files (createSymbolicLink) + +import SuperUserSpark.Bake +import SuperUserSpark.Bake.Gen () +import SuperUserSpark.Bake.Internal +import SuperUserSpark.Bake.Types +import SuperUserSpark.Compiler.Types +import SuperUserSpark.OptParse.Gen () +import SuperUserSpark.Parser.Gen + +spec :: Spec +spec = do + instanceSpec + bakeSpec + +instanceSpec :: Spec +instanceSpec = + parallel $ do + eqSpec @BakeAssignment + genValidSpec @BakeAssignment + eqSpec @BakeCardReference + genValidSpec @BakeCardReference + eqSpec @BakeSettings + genValidSpec @BakeSettings + eqSpec @BakeError + genValidSpec @BakeError + eqSpec @BakedDeployment + genValidSpec @BakedDeployment + jsonSpecOnValid @BakedDeployment + eqSpec @AbsP + genValidSpec @AbsP + eqSpec @(DeploymentDirections AbsP) + genValidSpec @(DeploymentDirections AbsP) + jsonSpecOnValid @(DeploymentDirections AbsP) + eqSpec @ID + genValidSpec @ID + +bakeSpec :: Spec +bakeSpec = + parallel $ do + describe "bakeFilePath" $ do + it "works for these unit test cases without variables" $ do + let b root fp s = do + absp <- AbsP <$> parseAbsFile s + rp <- parseAbsDir root + runReaderT + (runExceptT (bakeFilePath fp)) + defaultBakeSettings {bakeRoot = rp} `shouldReturn` + Right absp + b "/home/user/hello" "a/b/c" "/home/user/hello/a/b/c" + b "/home/user/hello" "/home/user/.files/c" "/home/user/.files/c" + it "works for a simple home-only variable situation" $ do + forAll genValid $ \root -> do + let b home fp s = do + absp <- AbsP <$> parseAbsFile s + runReaderT + (runExceptT (bakeFilePath fp)) + defaultBakeSettings + { bakeRoot = root + , bakeEnvironment = [("HOME", home)] + } `shouldReturn` + Right absp + b "/home/user" "~/a/b/c" "/home/user/a/b/c" + b "/home" "~/c" "/home/c" + here <- runIO getCurrentDir + let sandbox = here $(mkRelDir "test_sandbox") + before_ (ensureDir sandbox) $ + after_ (removeDirRecur sandbox) $ do + it + "does not follow toplevel links when the completed path is relative" $ do + let file = $(mkRelFile "file") + let from = $(mkRelDir "from") file + let to = $(mkRelDir "to") file + withCurrentDir sandbox $ do + ensureDir $ parent $ sandbox from + writeFile (sandbox from) "contents" + ensureDir $ parent $ sandbox to + createSymbolicLink + (toFilePath $ sandbox from) + (toFilePath $ sandbox to) + let runBake f = + runReaderT + (runExceptT f) + (defaultBakeSettings + {bakeRoot = sandbox, bakeEnvironment = []}) + runBake (bakeFilePath (toFilePath to)) `shouldReturn` + (Right $ AbsP $ sandbox to) + runBake (bakeFilePath (toFilePath from)) `shouldReturn` + (Right $ AbsP $ sandbox from) + it + "follows directory-level links when the completed path is relative" $ do + let file = $(mkRelFile "file") + let fromdir = $(mkRelDir "from") + let from = fromdir file + let todir = $(mkRelDir "to") + let to = todir file + withCurrentDir sandbox $ do + ensureDir $ parent $ sandbox from + writeFile (sandbox from) "from contents" + ensureDir $ parent $ sandbox todir + createSymbolicLink + (FP.dropTrailingPathSeparator $ + toFilePath $ sandbox fromdir) + (FP.dropTrailingPathSeparator $ + toFilePath $ sandbox todir) + writeFile (sandbox to) "to contents" + let runBake f = + runReaderT + (runExceptT f) + (defaultBakeSettings + {bakeRoot = sandbox, bakeEnvironment = []}) + runBake (bakeFilePath (toFilePath to)) `shouldReturn` + (Right $ AbsP $ sandbox from) + runBake (bakeFilePath (toFilePath from)) `shouldReturn` + (Right $ AbsP $ sandbox from) + describe "defaultBakeSettings" $ + it "is valid" $ isValid defaultBakeSettings + describe "formatBakeError" $ do + it "only ever produces valid strings" $ + producesValid formatBakeError + describe "complete" $ do + it "only ever produces a valid filepath" $ validIfSucceeds2 complete + 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", home) : env) ("~" FP. fp) `shouldBe` + Right (home FP. fp) + describe "parseId" $ do + it "only ever produces valid IDs" $ producesValid parseId + it "Figures out the home directory in these cases" $ do + parseId "~" `shouldBe` [Var "HOME"] + parseId "~/ab" `shouldBe` [Var "HOME", Plain "/ab"] + 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 "only ever produces valid FilePaths" $ validIfSucceeds2 replaceId + it "leaves plain ID's unchanged in any environment" $ + forAll arbitrary $ \env -> + forAll arbitrary $ \s -> + replaceId env (Plain s) `shouldBe` Right s + it "returns Left if a variable is not in the environment" $ + 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" $ + 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 diff --git a/test/SuperUserSpark/Check/Gen.hs b/test/SuperUserSpark/Check/Gen.hs new file mode 100644 --- /dev/null +++ b/test/SuperUserSpark/Check/Gen.hs @@ -0,0 +1,69 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module SuperUserSpark.Check.Gen where + +import TestImport + +import SuperUserSpark.Bake.Gen () +import SuperUserSpark.Check.Types +import SuperUserSpark.Compiler.Gen () +import SuperUserSpark.Diagnose.Gen () +import SuperUserSpark.Language.Gen () + +instance GenUnchecked CheckAssignment + +instance GenValid CheckAssignment where + genValid = CheckAssignment <$> genValid <*> genValid + +instance GenUnchecked CheckSettings + +instance GenValid CheckSettings where + genValid = CheckSettings <$> genValid + +instance GenUnchecked CheckError + +instance GenValid CheckError + +instance GenUnchecked CheckResult where + genUnchecked = + oneof + [ pure AlreadyDone + , Ready <$> genUnchecked + , Dirty <$> genUnchecked <*> genUnchecked <*> genUnchecked + , Impossible <$> genUnchecked + ] + +instance GenValid CheckResult where + genValid = + oneof + [ pure AlreadyDone + , Ready <$> genValid + , Dirty <$> genValid <*> genValid <*> genValid + , Impossible <$> genValid + ] + +instance GenUnchecked Instruction + +instance GenValid Instruction where + genValid = + oneof + [ CopyFile <$> genValid <*> genValid + , CopyDir <$> genValid <*> genValid + , LinkFile <$> genValid <*> genValid + , LinkDir <$> genValid <*> genValid + ] + +instance GenUnchecked CleanupInstruction + +instance GenValid CleanupInstruction + +instance GenUnchecked DeploymentCheckResult where + genUnchecked = + oneof + [ pure DeploymentDone + , ReadyToDeploy <$> genUnchecked + , DirtySituation <$> genUnchecked <*> genUnchecked <*> genUnchecked + , ImpossibleDeployment <$> genUnchecked + ] + +instance GenValid DeploymentCheckResult diff --git a/test/SuperUserSpark/Check/TestUtils.hs b/test/SuperUserSpark/Check/TestUtils.hs new file mode 100644 --- /dev/null +++ b/test/SuperUserSpark/Check/TestUtils.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE TemplateHaskell #-} + +module SuperUserSpark.Check.TestUtils where + +import TestImport + +import SuperUserSpark.Bake.Gen () +import SuperUserSpark.Bake.Types +import SuperUserSpark.Check.Gen () +import SuperUserSpark.Check.Internal +import SuperUserSpark.Check.Types +import SuperUserSpark.CoreTypes +import SuperUserSpark.Diagnose.Types + +-- * Test utils for checkDeployment +shouldBeImpossible' :: DiagnosedDeployment -> Expectation +shouldBeImpossible' dd = checkDeployment dd `shouldSatisfy` impossibleDeployment + +shouldBeImpossibleDeployment :: [CheckResult] -> Expectation +shouldBeImpossibleDeployment dd = + bestResult dd `shouldSatisfy` impossibleDeployment + +-- * Test utils for checkSingle +isDirty :: CheckResult -> Bool +isDirty (Dirty _ _ _) = True +isDirty _ = False + +isReady :: CheckResult -> Bool +isReady (Ready _) = True +isReady _ = False + +isDone :: CheckResult -> Bool +isDone AlreadyDone = True +isDone _ = False + +isImpossible :: CheckResult -> Bool +isImpossible (Impossible _) = True +isImpossible _ = False + +shouldBeDirty + :: DiagnosedFp + -> DiagnosedFp + -> DeploymentKind + -> CleanupInstruction + -> Expectation +shouldBeDirty src dst kind eci = + case checkSingle src dst kind of + Dirty _ ins ci -> do + ci `shouldBe` eci + let tp = dropTrailingPathSeparator . toFilePath + case ins of + CopyFile isrc idst -> do + tp isrc `shouldBe` toPath (diagnosedFilePath src) + tp idst `shouldBe` toPath (diagnosedFilePath dst) + CopyDeployment `shouldBe` kind + CopyDir isrc idst -> do + tp isrc `shouldBe` toPath (diagnosedFilePath src) + tp idst `shouldBe` toPath (diagnosedFilePath dst) + CopyDeployment `shouldBe` kind + LinkFile isrc idst -> do + tp isrc `shouldBe` toPath (diagnosedFilePath src) + tp idst `shouldBe` toPath (diagnosedFilePath dst) + LinkDeployment `shouldBe` kind + LinkDir isrc idst -> do + tp isrc `shouldBe` toPath (diagnosedFilePath src) + tp idst `shouldBe` toPath (diagnosedFilePath dst) + LinkDeployment `shouldBe` kind + t -> + expectationFailure $ + unlines + [ "checkSingle" + , show src + , show dst + , show kind + , "should be dirty but is" + , show t + ] + +shouldBeReady :: DiagnosedFp -> DiagnosedFp -> DeploymentKind -> Expectation +shouldBeReady src dst kind = checkSingle src dst kind `shouldSatisfy` isReady + +shouldBeDone :: DiagnosedFp -> DiagnosedFp -> DeploymentKind -> Expectation +shouldBeDone src dst kind = checkSingle src dst kind `shouldSatisfy` isDone + +shouldBeImpossible :: DiagnosedFp + -> DiagnosedFp + -> DeploymentKind + -> Expectation +shouldBeImpossible src dst kind = + checkSingle src dst kind `shouldSatisfy` isImpossible + +validWith :: Diagnostics -> Gen DiagnosedFp +validWith d = D <$> genValid <*> pure d <*> genValid diff --git a/test/SuperUserSpark/CheckSpec.hs b/test/SuperUserSpark/CheckSpec.hs new file mode 100644 --- /dev/null +++ b/test/SuperUserSpark/CheckSpec.hs @@ -0,0 +1,253 @@ +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TemplateHaskell #-} + +module SuperUserSpark.CheckSpec where + +import TestImport + +import Control.Monad (forM_) +import Data.Hashable +import System.FilePath (dropTrailingPathSeparator) +import System.Posix.Files + +import SuperUserSpark.Bake.Types +import SuperUserSpark.Check +import SuperUserSpark.Check.Gen () +import SuperUserSpark.Check.Internal +import SuperUserSpark.Check.TestUtils +import SuperUserSpark.Check.Types +import SuperUserSpark.Compiler.Types +import SuperUserSpark.CoreTypes +import SuperUserSpark.Diagnose.Internal +import SuperUserSpark.Diagnose.TestUtils +import SuperUserSpark.Diagnose.Types +import SuperUserSpark.OptParse.Gen () +import SuperUserSpark.Parser.Gen () +import SuperUserSpark.Utils +import TestUtils + +spec :: Spec +spec = do + instanceSpec + checkSpec + +instanceSpec :: Spec +instanceSpec = do + eqSpec @CheckSettings + genValidSpec @CheckSettings + eqSpec @Instruction + genValidSpec @Instruction + eqSpec @CleanupInstruction + genValidSpec @CleanupInstruction + eqSpec @DeploymentCheckResult + genValidSpec @DeploymentCheckResult + eqSpec @CheckResult + genValidSpec @CheckResult + +checkSpec :: Spec +checkSpec = + parallel $ do + describe "formatCheckError" $ + it "always produces valid strings" $ producesValid formatCheckError + checkSingleSpec + checkDeploymentSpec + describe "formatDeploymentChecks" $ + it "always produces valid strings" $ + producesValid formatDeploymentChecks + describe "formatDeploymentCheck" $ + it "always produces valid strings" $ + producesValid formatDeploymentCheck + describe "formatInstruction" $ + it "always produces valid strings" $ producesValid formatInstruction + describe "formatCleanupInstruction" $ + it "always produces valid strings" $ + producesValid formatCleanupInstruction + +checkDeploymentSpec :: Spec +checkDeploymentSpec = do + describe "checkDeployment" $ do + it "always produces valid check results" $ + producesValidsOnValids checkDeployment + it "says 'impossible' for deployments with an empty list of sources" $ do + forAll genUnchecked $ \dst -> + forAll genUnchecked $ \kind -> + shouldBeImpossible' $ Deployment (Directions [] dst) kind + it "says 'impossible' for deployments where all singles are impossible" $ do + forAll + (genValid `suchThat` + (\(Deployment (Directions 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 + forAll genValid $ \dd@(Deployment (Directions 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 "always produces valid check results" $ + producesValidsOnValids bestResult + it "says 'impossible' if all checkresults are impossible" $ do + forAll + (genValid `suchThat` all isImpossible) + shouldBeImpossibleDeployment + it "says 'done' if the first non-impossible in 'done'" $ do + forAll + (genValid `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 + (genValid `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 + (genValid `suchThat` + (any (not . isImpossible) &&& + (isReady . head . dropWhile isImpossible))) $ \dd -> + bestResult dd `shouldSatisfy` deploymentReadyToDeploy + +checkSingleSpec :: Spec +checkSingleSpec = + describe "checkSingle" $ do + it "always produces valid CheckResults" $ + producesValidsOnValids3 checkSingle + it "says 'impossible' if the source does not exist" $ do + forAll (validWith Nonexistent) $ \src -> + forAll genValid $ \dst -> + forAll genValid $ \kind -> shouldBeImpossible src dst kind + it + "says 'ready' if the source is a file and the destination does not exist" $ do + forAll (validWith IsFile) $ \src -> + forAll (validWith Nonexistent) $ \dst -> + forAll genValid $ \kind -> shouldBeReady src dst kind + it + "says 'dirty' if both the source and destination are files and it's a link deployment" $ do + forAll (validWith IsFile) $ \src -> + forAll (validWith IsFile) $ \dst -> + shouldBeDirty src dst LinkDeployment $ + CleanFile $ unAbsP $ 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 genValid $ \src -> + forAll genValid $ \dst -> + forAll genValid $ \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 genValid $ \src -> + forAll genValid $ \dst -> + forAll genValid $ \h1 -> + forAll (genValid `suchThat` (/= h1)) $ \h2 -> + shouldBeDirty + (D src IsFile h1) + (D dst IsFile h2) + CopyDeployment $ + CleanFile $ unAbsP dst + it + "says 'dirty' if the source is a file and the destination is a directory" $ do + forAll (validWith IsFile) $ \src -> + forAll (validWith IsDirectory) $ \dst -> + forAll genValid $ \kind -> do + d <- parseAbsDir (toPath $ diagnosedFilePath dst) + shouldBeDirty src dst kind $ CleanDirectory d + 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 (validWith IsFile) $ \src@(D srcp _ _) -> + forAll (genValid `suchThat` (/= srcp)) $ \l -> + forAll (validWith $ IsLinkTo l) $ \dst -> + shouldBeDirty src dst LinkDeployment $ + CleanLink $ unAbsP $ 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 (validWith IsFile) $ \src@(D srcp _ _) -> + forAll (validWith $ 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 (validWith IsFile) $ \src -> + forAll genValid $ \l -> + forAll (validWith $ IsLinkTo l) $ \dst -> + shouldBeDirty src dst CopyDeployment $ + CleanLink $ unAbsP $ diagnosedFilePath dst + it + "says 'ready' if the source is a directory and the destination does not exist" $ do + forAll (validWith IsDirectory) $ \src -> + forAll (validWith Nonexistent) $ \dst -> + forAll genValid $ \kind -> shouldBeReady src dst kind + it + "says 'dirty' if the source is a directory and the destination is a file" $ do + forAll (validWith IsDirectory) $ \src -> + forAll (validWith IsFile) $ \dst -> + forAll genValid $ \kind -> + shouldBeDirty src dst kind $ + CleanFile $ unAbsP $ diagnosedFilePath dst + it + "says 'dirty' if both the source and destination are directories for a link deployment" $ do + forAll (validWith IsDirectory) $ \src -> + forAll (validWith IsDirectory) $ \dst -> do + d <- parseAbsDir (toPath $ diagnosedFilePath dst) + shouldBeDirty src dst LinkDeployment $ CleanDirectory d + it + "says 'done' if both the source and destination are directories and it's a copy deployment and the directories are equal" $ do + forAll genValid $ \src -> + forAll genValid $ \dst -> + forAll genValid $ \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 genValid $ \src -> + forAll genValid $ \dst -> + forAll genValid $ \h1 -> + forAll (genValid `suchThat` (/= h1)) $ \h2 -> do + d <- parseAbsDir $ toPath dst + shouldBeDirty + (D src IsDirectory h1) + (D dst IsDirectory h2) + CopyDeployment $ + CleanDirectory d + 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 (validWith IsDirectory) $ \src@(D srcp _ _) -> + forAll (genValid `suchThat` (/= srcp)) $ \l -> + forAll (validWith $ IsLinkTo l) $ \dst -> + shouldBeDirty src dst LinkDeployment $ + CleanLink $ unAbsP $ 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 (validWith IsDirectory) $ \src@(D srcp _ _) -> + forAll (validWith $ 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 (validWith IsDirectory) $ \src -> + forAll genValid $ \l -> + forAll (validWith $ IsLinkTo l) $ \dst -> + shouldBeDirty src dst CopyDeployment $ + CleanLink $ unAbsP $ diagnosedFilePath dst + it "says 'dirty' if the source is a link" $ do + forAll genValid $ \l -> + forAll (validWith $ IsLinkTo l) $ \src -> + forAll genValid $ \dst -> + forAll genValid $ \kind -> + shouldBeImpossible src dst kind + it "says 'dirty' for a weird source" $ do + forAll (validWith IsWeird) $ \src -> + forAll genValid $ \dst -> + forAll genValid $ \kind -> shouldBeImpossible src dst kind + it "says 'dirty' for a weird destination" $ do + forAll genValid $ \src -> + forAll (validWith IsWeird) $ \dst -> + forAll genValid $ \kind -> shouldBeImpossible src dst kind + it "works for these unit tests" $ do pending diff --git a/test/SuperUserSpark/Compiler/Gen.hs b/test/SuperUserSpark/Compiler/Gen.hs new file mode 100644 --- /dev/null +++ b/test/SuperUserSpark/Compiler/Gen.hs @@ -0,0 +1,60 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module SuperUserSpark.Compiler.Gen where + +import TestImport + +import SuperUserSpark.Compiler.Types +import SuperUserSpark.Language.Gen () +import SuperUserSpark.PreCompiler.Gen () + +instance GenUnchecked CompileAssignment + +instance GenValid CompileAssignment where + genValid = CompileAssignment <$> genValid <*> genValid <*> genValid + + +instance GenUnchecked StrongCardFileReference + +instance GenValid StrongCardFileReference + + +instance GenUnchecked CompileSettings + +instance GenValid CompileSettings where + genValid = CompileSettings <$> genValid <*> genValid + + +instance GenUnchecked a => + GenUnchecked (Deployment a) where + genUnchecked = Deployment <$> genUnchecked <*> genUnchecked + +instance GenValid a => + GenValid (Deployment a) where + genValid = Deployment <$> genValid <*> genValid + +instance GenUnchecked a => + GenUnchecked (DeploymentDirections a) + +instance GenValid a => + GenValid (DeploymentDirections a) where + genValid = Directions <$> genValid <*> genValid + +instance GenUnchecked PrefixPart + +instance GenValid PrefixPart + + +instance GenUnchecked CompilerState + +instance GenValid CompilerState + +instance GenUnchecked CompileError where + genUnchecked = + oneof + [ PreCompileErrors <$> genUnchecked + , DuringCompilationError <$> genUnchecked + ] + +instance GenValid CompileError + diff --git a/test/SuperUserSpark/Compiler/TestUtils.hs b/test/SuperUserSpark/Compiler/TestUtils.hs new file mode 100644 --- /dev/null +++ b/test/SuperUserSpark/Compiler/TestUtils.hs @@ -0,0 +1,95 @@ +module SuperUserSpark.Compiler.TestUtils where + +import TestImport + +import Data.Either (isLeft, isRight) + +import SuperUserSpark.Compiler.Internal +import SuperUserSpark.Compiler.Types +import SuperUserSpark.Language.Types +import SuperUserSpark.PreCompiler +import SuperUserSpark.PreCompiler.Types + +runPreCompiler :: Precompiler () -> [PreCompileError] +runPreCompiler pc = runIdentity $ execWriterT pc + +cleanBy :: (a -> Precompiler ()) -> a -> Bool +cleanBy func a = null $ runPreCompiler $ func a + +declarationClean :: Declaration -> IO () +declarationClean d = d `shouldSatisfy` cleanBy cleanDeclaration + +declarationDirty :: Declaration -> IO () +declarationDirty d = d `shouldNotSatisfy` cleanBy cleanDeclaration + +filePathDirty :: FilePath -> IO () +filePathDirty fp = fp `shouldNotSatisfy` cleanBy cleanFilePath + +filePathClean :: FilePath -> IO () +filePathClean fp = fp `shouldSatisfy` cleanBy cleanFilePath + +runPureCompiler :: CompileSettings -> PureCompiler a -> Either CompileError a +runPureCompiler c func = runIdentity $ runReaderT (runExceptT func) c + +runInternalCompiler + :: [Declaration] + -> CompilerState + -> CompileSettings + -> Either CompileError (CompilerState, ([RawDeployment], [CardReference])) +runInternalCompiler ds s c = + runPureCompiler c $ runWriterT $ execStateT (compileDecs ds) s + +compileSingleDec + :: Declaration + -> CompilerState + -> CompileSettings + -> Either CompileError (CompilerState, ([RawDeployment], [CardReference])) +compileSingleDec d = runInternalCompiler [d] + +compilationShouldSucceed :: [Declaration] + -> CompilerState + -> CompileSettings + -> IO () +compilationShouldSucceed ds s c = + runInternalCompiler ds s c `shouldSatisfy` isRight + +compilationShouldFail :: [Declaration] + -> CompilerState + -> CompileSettings + -> IO () +compilationShouldFail ds s c = runInternalCompiler ds s c `shouldSatisfy` isLeft + +singleShouldFail :: CompileSettings -> CompilerState -> Declaration -> IO () +singleShouldFail c s d = compilationShouldFail [d] s c + +shouldCompileTo :: CompileSettings + -> CompilerState + -> [Declaration] + -> [RawDeployment] + -> IO () +shouldCompileTo c s ds eds = do + compilationShouldSucceed ds s c + let Right (_, (ads, crs)) = runInternalCompiler ds s c + ads `shouldBe` eds + crs `shouldSatisfy` null + +singleShouldCompileTo :: CompileSettings + -> CompilerState + -> Declaration + -> RawDeployment + -> IO () +singleShouldCompileTo c s d eds = shouldCompileTo c s [d] [eds] + +shouldResultInState :: CompileSettings + -> CompilerState + -> Declaration + -> CompilerState + -> IO () +shouldResultInState c s d es = do + compilationShouldSucceed [d] s c + let Right (as, _) = runInternalCompiler [d] s c + as `shouldBe` es + +-- Filepath utils +containsNewlineCharacter :: String -> Bool +containsNewlineCharacter f = any (\c -> elem c f) ['\n', '\r'] diff --git a/test/SuperUserSpark/CompilerSpec.hs b/test/SuperUserSpark/CompilerSpec.hs new file mode 100644 --- /dev/null +++ b/test/SuperUserSpark/CompilerSpec.hs @@ -0,0 +1,422 @@ +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TemplateHaskell #-} + +module SuperUserSpark.CompilerSpec where + +import TestImport + +import Data.Either (isLeft, isRight) +import Data.List (isPrefixOf) +import System.FilePath.Posix ((<.>)) + +import SuperUserSpark.Compiler +import SuperUserSpark.Compiler.Gen () +import SuperUserSpark.Compiler.Internal +import SuperUserSpark.Compiler.TestUtils +import SuperUserSpark.Compiler.Types +import SuperUserSpark.Compiler.Utils +import SuperUserSpark.CoreTypes +import SuperUserSpark.Language.Gen () +import SuperUserSpark.Language.Types +import SuperUserSpark.OptParse.Gen () +import SuperUserSpark.PreCompiler +import SuperUserSpark.Utils +import TestUtils + +spec :: Spec +spec = do + parallel $ do + instanceSpec + compileSpec + singleCompileDecSpec + precompileSpec + compileUnitSpec + utilsSpec + hopTests + exactTests + compilerBlackBoxTests + +precompileSpec :: Spec +precompileSpec = describe "pre-compilation" $ do cleanContentSpec + +cleanContentSpec :: Spec +cleanContentSpec = do + let validFp = genValid `suchThat` cleanBy cleanFilePath + describe "cleanCard" $ do + it "doesn't report any card with valid content and a valid name" $ do + forAll (genValid `suchThat` cleanBy cleanCardName) $ \cn -> + forAll (genValid `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 (genValid `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 genValid $ \kind -> + Deploy src dst kind `shouldSatisfy` + cleanBy cleanDeclaration + it "reports Deploy declarations with an invalid source" $ do + forAll (genValid `suchThat` (not . cleanBy cleanFilePath)) $ \src -> + forAll validFp $ \dst -> + forAll genValid $ \kind -> + Deploy src dst kind `shouldNotSatisfy` + cleanBy cleanDeclaration + it "reports Deploy declarations with an invalid destination" $ do + forAll validFp $ \src -> + forAll (genValid `suchThat` (not . cleanBy cleanFilePath)) $ \dst -> + forAll genValid $ \kind -> + Deploy src dst kind `shouldNotSatisfy` + cleanBy cleanDeclaration + pend + describe "SparkOff" $ do + it "reports SparkOff declarations with an invalid card reference" $ do + forAll (genValid `suchThat` (not . cleanBy cleanCardReference)) $ \cr -> + SparkOff cr `shouldNotSatisfy` cleanBy cleanDeclaration + it + "doesn't report SparkOff declarations with a valid card reference" $ do + forAll (genValid `suchThat` cleanBy cleanCardReference) $ \cr -> + SparkOff cr `shouldSatisfy` cleanBy cleanDeclaration + pend + describe "IntoDir" $ do + it "reports IntoDir declarations with an invalid filepath" $ do + forAll (genValid `suchThat` (not . cleanBy cleanFilePath)) $ \fp -> + IntoDir fp `shouldNotSatisfy` cleanBy cleanDeclaration + it "doesn't report IntoDir declarations with a valid filepath" $ do + forAll (genValid `suchThat` cleanBy cleanFilePath) $ \fp -> + IntoDir fp `shouldSatisfy` cleanBy cleanDeclaration + pend + describe "OutofDir" $ do + it "reports OutofDir declarations with an invalid filepath" $ do + forAll (genValid `suchThat` (not . cleanBy cleanFilePath)) $ \fp -> + OutofDir fp `shouldNotSatisfy` cleanBy cleanDeclaration + it "doesn't report OutofDir declarations with a valid filepath" $ do + forAll (genValid `suchThat` cleanBy cleanFilePath) $ \fp -> + OutofDir fp `shouldSatisfy` cleanBy cleanDeclaration + pend + describe "DeployKindOverride" $ do + it "doesn't report any deployment kind override declarations" $ do + forAll genValid $ \kind -> + DeployKindOverride kind `shouldSatisfy` + cleanBy cleanDeclaration + pend + describe "Alternatives" $ do + it + "reports alternatives declarations with as much as a single invalid filepath" $ do + forAll (genValid `suchThat` (any $ not . cleanBy cleanFilePath)) $ \fs -> + Alternatives fs `shouldNotSatisfy` cleanBy cleanDeclaration + it "doesn't report alternatives declarations with valid filepaths" $ do + forAll (genValid `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 + (genValid `suchThat` (any $ not . cleanBy cleanDeclaration)) $ \ds -> + Block ds `shouldNotSatisfy` cleanBy cleanDeclaration + it + "doesn't report any block declarations with valid declarations inside" $ do + forAll (genValid `suchThat` (all $ cleanBy cleanDeclaration)) $ \ds -> + Block ds `shouldSatisfy` cleanBy cleanDeclaration + pend + describe "cleanCardReference" $ do + it "works the same as cleanCardName separately" $ do + forAll genValid $ \cnr -> + cleanBy cleanCardNameReference cnr === + cleanBy cleanCardReference (CardName cnr) + it "works the same as cleanCardFile separately" $ do + forAll genValid $ \cfr -> + cleanBy cleanCardFileReference cfr === + cleanBy cleanCardReference (CardFile cfr) + pend + describe "cleanCardNameReference" $ do + it "reports card name references with an invalid card name" $ do + forAll (genValid `suchThat` (not . cleanBy cleanCardName)) $ \cn -> + CardNameReference cn `shouldNotSatisfy` + cleanBy cleanCardNameReference + it "doesn't report card name references with a valid card name" $ do + forAll (genValid `suchThat` cleanBy cleanCardName) $ \cn -> + CardNameReference cn `shouldSatisfy` + cleanBy cleanCardNameReference + pend + describe "cleanCardFileReference" $ do + it "reports card file references with an invalid filepath" $ do + forAll (genValid `suchThat` (not . cleanBy cleanFilePath)) $ \fp -> + forAll genValid $ \cn -> + CardFileReference fp cn `shouldNotSatisfy` + cleanBy cleanCardFileReference + it "reports card file references with an invalid card name" $ do + forAll genValid $ \fp -> + forAll + (genValid `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 (genValid `suchThat` cleanBy cleanFilePath) $ \fp -> + forAll (genValid `suchThat` cleanBy cleanCardNameReference) $ \cn -> + CardFileReference fp (Just cn) `shouldSatisfy` + cleanBy cleanCardFileReference + pend + describe "cleanFilePath" $ do + it "reports empty an filepath" $ do filePathDirty [] + let nonNull = genValid `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 + { stateDeploymentKindLocalOverride = Nothing + , stateInto = "" + , stateOutof_prefix = [] + } + +instanceSpec :: Spec +instanceSpec = + parallel $ do + eqSpec @CompileAssignment + genValidSpec @CompileAssignment + eqSpec @CompileSettings + genValidSpec @CompileSettings + eqSpec @(Deployment FilePath) + genValidSpec @(Deployment FilePath) + jsonSpecOnValid @(Deployment FilePath) + functorSpec @Deployment + eqSpec @(DeploymentDirections FilePath) + genValidSpec @(DeploymentDirections FilePath) + jsonSpecOnValid @(DeploymentDirections FilePath) + functorSpec @DeploymentDirections + eqSpec @PrefixPart + genValidSpec @PrefixPart + eqSpec @CompilerState + genValidSpec @CompilerState + eqSpec @CompileError + genValidSpec @CompileError + +compileSpec :: Spec +compileSpec = do + describe "formatCompileError" $ + it "only produces valid strings" $ producesValid formatCompileError + +singleCompileDecSpec :: Spec +singleCompileDecSpec = + describe "compileDec" $ do + let s = defaultCompilerState + let c = defaultCompileSettings + let sc = singleShouldCompileTo c s + let nonNull = genValid `suchThat` (not . null) + let validFilePath = nonNull `suchThat` (not . containsNewlineCharacter) + let easyFilePath = validFilePath `suchThat` (not . isPrefixOf ".") + let validFp = genValid `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) + (Deployment (Directions [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 (Deployment (Directions ["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 {stateInto = 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 {stateOutof_prefix = [Literal fp]} + pend + describe "DeployKindOverride" $ do + it "modifies the internal deployment kind override" $ do + forAll genValid $ \kind -> + shouldState (DeployKindOverride kind) $ + s {stateDeploymentKindLocalOverride = Just kind} + pend + describe "Block" $ do + it "uses a separate scope for its sub-compilation" $ do + forAll genValid $ \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 {stateOutof_prefix = [Alts fps]} + pend + +runDefaultImpureCompiler :: ImpureCompiler a -> IO (Either CompileError a) +runDefaultImpureCompiler = flip runReaderT defaultCompileSettings . runExceptT + +compileUnitSpec :: Spec +compileUnitSpec = + describe "compileUnit" $ do + it "Only ever produces valid results" $ + forAll genValid $ \sets -> + validIfSucceeds + (runIdentity . + flip runReaderT sets . runExceptT . compileUnit) + +utilsSpec :: Spec +utilsSpec = + parallel $ do + describe "initialState" $ it "is valid" $ isValid initialState + describe "sources" $ + it "only produces valid prefix parts" $ producesValid sources + describe "resolvePrefix" $ + it "only produces valid paths" $ producesValid resolvePrefix + +hopTests :: Spec +hopTests = do + describe "hop test" $ do + dir <- runIO $ resolveDir' "test_resources/hop_test" + let root = dir $(mkRelFile "root.sus") + let hop1 = dir $(mkRelDir "hop1dir") $(mkRelFile "hop1.sus") + let hop2 = + dir $(mkRelDir "hop1dir") $(mkRelDir "hop2dir") + $(mkRelFile "hop2.sus") + let hop3 = + dir $(mkRelDir "hop1dir") $(mkRelDir "hop2dir") + $(mkRelDir "hop3dir") + $(mkRelFile "hop3.sus") + it "compiles hop3 correctly" $ do + r <- + runDefaultImpureCompiler $ + compileJob $ StrongCardFileReference hop3 Nothing + r `shouldBe` + Right + [ Deployment + (Directions ["z/delta"] "d/three") + LinkDeployment + ] + it "compiles hop2 correctly" $ do + r <- + runDefaultImpureCompiler $ + compileJob $ StrongCardFileReference hop2 Nothing + r `shouldBe` + Right + [ Deployment (Directions ["y/gamma"] "c/two") LinkDeployment + , Deployment + (Directions ["hop3dir/z/delta"] "d/three") + LinkDeployment + ] + it "compiles hop1 correctly" $ do + r <- + runDefaultImpureCompiler $ + compileJob $ StrongCardFileReference hop1 Nothing + r `shouldBe` + Right + [ Deployment (Directions ["x/beta"] "b/one") LinkDeployment + , Deployment + (Directions ["hop2dir/y/gamma"] "c/two") + LinkDeployment + , Deployment + (Directions ["hop2dir/hop3dir/z/delta"] "d/three") + LinkDeployment + ] + it "compiles root correctly" $ do + r <- + runDefaultImpureCompiler $ + compileJob $ StrongCardFileReference root Nothing + r `shouldBe` + Right + [ Deployment + (Directions ["u/alpha"] "a/zero") + LinkDeployment + , Deployment + (Directions ["hop1dir/x/beta"] "b/one") + LinkDeployment + , Deployment + (Directions ["hop1dir/hop2dir/y/gamma"] "c/two") + LinkDeployment + , Deployment + (Directions + ["hop1dir/hop2dir/hop3dir/z/delta"] + "d/three") + LinkDeployment + ] + +exactTests :: Spec +exactTests = do + describe "exact tests" $ do + dir <- runIO $ resolveDir' "test_resources/exact_compile_test_src" + forFileInDirss [dir] $ \fp -> + if fileExtension fp == ".res" + then return () + else do + it (toFilePath fp) $ do + let orig = fp + result <- parseAbsFile $ toFilePath fp <.> "res" + ads <- + runDefaultImpureCompiler $ + compileJob $ StrongCardFileReference orig Nothing + eds <- runDefaultImpureCompiler $ inputCompiled result + ads `shouldBe` eds + +hopTestDir :: Path Rel Dir +hopTestDir = $(mkRelDir "hop_test") + +compilerBlackBoxTests :: Spec +compilerBlackBoxTests = do + tr <- runIO $ resolveDir' "test_resources" + describe "Succesful compile examples" $ do + let dirs = map (tr ) [shouldCompileDir, hopTestDir] + forFileInDirss dirs $ \f -> do + it (toFilePath f) $ do + r <- + runDefaultImpureCompiler $ + compileJob $ StrongCardFileReference f Nothing + r `shouldSatisfy` isRight + describe "Unsuccesfull compile examples" $ do + let dirs = map (tr ) [shouldNotParseDir, shouldNotCompileDir] + forFileInDirss dirs $ \f -> do + it (toFilePath f) $ do + r <- + runDefaultImpureCompiler $ + compileJob $ StrongCardFileReference f Nothing + r `shouldSatisfy` isLeft diff --git a/test/SuperUserSpark/Deployer/Gen.hs b/test/SuperUserSpark/Deployer/Gen.hs new file mode 100644 --- /dev/null +++ b/test/SuperUserSpark/Deployer/Gen.hs @@ -0,0 +1,30 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module SuperUserSpark.Deployer.Gen where + +import TestImport + +import SuperUserSpark.Check.Gen () +import SuperUserSpark.Deployer.Types + +instance GenUnchecked DeployAssignment + +instance GenValid DeployAssignment where + genValid = DeployAssignment <$> genValid <*> genValid + +instance GenUnchecked DeploySettings + +instance GenValid DeploySettings where + genValid = + DeploySettings <$> genValid <*> genValid <*> genValid <*> genValid + + +instance GenUnchecked DeployError + +instance GenValid DeployError + + +instance GenUnchecked PreDeployment + +instance GenValid PreDeployment + diff --git a/test/SuperUserSpark/DeployerSpec.hs b/test/SuperUserSpark/DeployerSpec.hs new file mode 100644 --- /dev/null +++ b/test/SuperUserSpark/DeployerSpec.hs @@ -0,0 +1,257 @@ +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TemplateHaskell #-} + +module SuperUserSpark.DeployerSpec where + +import TestImport + +import System.Posix.Files + +import SuperUserSpark.Bake.Types +import SuperUserSpark.Check.Internal +import SuperUserSpark.Check.Types +import SuperUserSpark.Deployer +import SuperUserSpark.Deployer.Gen () +import SuperUserSpark.Deployer.Internal +import SuperUserSpark.Deployer.Types +import SuperUserSpark.Diagnose.Internal +import SuperUserSpark.Diagnose.Types +import SuperUserSpark.OptParse.Gen () +import SuperUserSpark.Parser.Gen () + +spec :: Spec +spec = do + instanceSpec + deployerSpec + cleanSpec + deploymentSpec + +instanceSpec :: Spec +instanceSpec = + parallel $ do + eqSpec @DeployAssignment + genValidSpec @DeployAssignment + eqSpec @DeploySettings + genValidSpec @DeploySettings + eqSpec @DeployError + genValidSpec @DeployError + eqSpec @PreDeployment + genValidSpec @PreDeployment + +deployerSpec :: Spec +deployerSpec = + parallel $ do + describe "defaultDeploySettings" $ + it "is valid" $ isValid defaultDeploySettings + describe "formatDeployError" $ do + it "only ever produces valid strings" $ + producesValid formatDeployError + +cleanSpec :: Spec +cleanSpec = do + here <- runIO getCurrentDir + let sandbox = here $(mkRelDir "test_sandbox") + let setup = ensureDir sandbox + let teardown = removeDirRecur sandbox + let clean :: DeploySettings -> CleanupInstruction -> IO () + clean sets ci = + runReaderT (runExceptT $ performClean ci) sets `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 = + defaultDeploySettings + {deploySetsReplaceFiles = False} + withCurrentDir sandbox $ do + let file = sandbox $(mkRelFile "test.txt") + let fp = AbsP file + writeFile file "This is a test" + diagnoseFp fp `shouldReturn` IsFile + clean c $ CleanFile file + diagnoseFp fp `shouldReturn` IsFile + removeFile file + diagnoseFp fp `shouldReturn` Nonexistent + it "removes this file if that's in the config" $ do + let c = + defaultDeploySettings + {deploySetsReplaceFiles = True} + withCurrentDir sandbox $ do + let file = sandbox $(mkRelFile "test.txt") + let fp = AbsP file + writeFile file "This is a test" + diagnoseFp fp `shouldReturn` IsFile + clean c $ CleanFile file + diagnoseFp fp `shouldReturn` Nonexistent + it "doesn't remove this directory if that's not in the config" $ do + let c = + defaultDeploySettings + {deploySetsReplaceDirectories = False} + withCurrentDir sandbox $ do + let dir = sandbox $(mkRelDir "testdirectory") + let dirf = + AbsP $ sandbox $(mkRelFile "testdirectory") + ensureDir dir + diagnoseFp dirf `shouldReturn` IsDirectory + clean c $ CleanDirectory dir + diagnoseFp dirf `shouldReturn` IsDirectory + removeDirRecur dir + diagnoseFp dirf `shouldReturn` Nonexistent + it "removes this directory if that's in the config" $ do + let c = + defaultDeploySettings + {deploySetsReplaceDirectories = True} + withCurrentDir sandbox $ do + let dir = sandbox $(mkRelDir "testdirectory") + let dirf = + AbsP $ sandbox $(mkRelFile "testdirectory") + ensureDir dir + diagnoseFp dirf `shouldReturn` IsDirectory + clean c $ CleanDirectory dir + diagnoseFp dirf `shouldReturn` Nonexistent + it "doesn't remove this link if that's not in the config" $ do + let c = + defaultDeploySettings + {deploySetsReplaceLinks = False} + withCurrentDir sandbox $ do + let link_ = sandbox $(mkRelFile "testlink") + let link_' = AbsP link_ + let file_ = sandbox $(mkRelFile "testfile") + let file_' = AbsP file_ + writeFile file_ "This is a test" + createSymbolicLink (toFilePath file_) (toFilePath link_) + diagnoseFp link_' `shouldReturn` IsLinkTo file_' + clean c $ CleanLink link_ + diagnoseFp link_' `shouldReturn` IsLinkTo file_' + removeLink $ toFilePath 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 = + defaultDeploySettings + {deploySetsReplaceLinks = True} + withCurrentDir sandbox $ do + let link_ = sandbox $(mkRelFile "testlink") + let link_' = AbsP link_ + let file_ = sandbox $(mkRelFile "testfile") + let file_' = AbsP file_ + writeFile file_ "This is a test" + createSymbolicLink (toFilePath file_) (toFilePath link_) + diagnoseFp link_' `shouldReturn` IsLinkTo file_' + clean c $ CleanLink link_ + diagnoseFp link_' `shouldReturn` Nonexistent + diagnoseFp file_' `shouldReturn` IsFile + removeFile file_ + diagnoseFp file_' `shouldReturn` Nonexistent + it + "removes this link with a nonexistent source if that's in the config" $ do + let c = + defaultDeploySettings + {deploySetsReplaceLinks = True} + withCurrentDir sandbox $ do + let link_ = sandbox $(mkRelFile "testlink") + let link_' = AbsP link_ + let file_ = sandbox $(mkRelFile "testfile") + let file_' = AbsP file_ + createSymbolicLink (toFilePath file_) (toFilePath 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 + here <- runIO $ getCurrentDir + let sandbox = here $(mkRelDir "test_sandbox") + let setup = ensureDir sandbox + let teardown = removeDirRecur sandbox + beforeAll_ setup $ + afterAll_ teardown $ do + describe "performCopyFile" $ do + it "succcesfully copies this file" $ do + withCurrentDir sandbox $ do + let src = sandbox $(mkRelFile "testfile") + let src' = AbsP src + let dst = sandbox $(mkRelFile "testcopy") + let dst' = AbsP dst + writeFile src "This is a file." + diagnoseFp src' `shouldReturn` IsFile + diagnoseFp dst' `shouldReturn` Nonexistent + -- Under test + performCopyFile src dst + diagnoseFp src' `shouldReturn` IsFile + diagnoseFp dst' `shouldReturn` IsFile + dsrc <- diagnoseAbsP src' + ddst <- diagnoseAbsP dst' + diagnosedHashDigest ddst `shouldBe` + diagnosedHashDigest dsrc + removeFile src + removeFile dst + diagnoseFp src' `shouldReturn` Nonexistent + diagnoseFp dst' `shouldReturn` Nonexistent + describe "performCopyDir" $ do + it "succcesfully copies this directory" $ do + withCurrentDir sandbox $ do + let src = sandbox $(mkRelDir "testdir") + let src' = AbsP $ sandbox $(mkRelFile "testdir") + let dst = sandbox $(mkRelDir "testcopy") + let dst' = AbsP $ sandbox $(mkRelFile "testcopy") + ensureDir src + diagnoseFp src' `shouldReturn` IsDirectory + diagnoseFp dst' `shouldReturn` Nonexistent + -- Under test + performCopyDir src dst + diagnoseFp src' `shouldReturn` IsDirectory + diagnoseFp dst' `shouldReturn` IsDirectory + dsrc <- diagnoseAbsP src' + ddst <- diagnoseAbsP dst' + diagnosedHashDigest ddst `shouldBe` + diagnosedHashDigest dsrc + removeDirRecur src + removeDirRecur dst + diagnoseFp src' `shouldReturn` Nonexistent + diagnoseFp dst' `shouldReturn` Nonexistent + describe "performLinkFile" $ do + it "successfully links this file" $ do + withCurrentDir sandbox $ do + let src = sandbox $(mkRelFile "testfile") + let src' = AbsP src + let dst = sandbox $(mkRelFile "testlink") + let dst' = AbsP dst + diagnoseFp src' `shouldReturn` Nonexistent + diagnoseFp dst' `shouldReturn` Nonexistent + writeFile src "This is a test." + diagnoseFp src' `shouldReturn` IsFile + diagnoseFp dst' `shouldReturn` Nonexistent + -- Under test + performLinkFile src dst + diagnoseFp src' `shouldReturn` IsFile + diagnoseFp dst' `shouldReturn` IsLinkTo src' + removeFile src + removeLink $ toFilePath dst + diagnoseFp src' `shouldReturn` Nonexistent + diagnoseFp dst' `shouldReturn` Nonexistent + describe "performLinkDir" $ do + it "successfully links this directory" $ do + withCurrentDir sandbox $ do + let src = sandbox $(mkRelDir "testdir") + let src' = AbsP $ sandbox $(mkRelFile "testdir") + let dst = sandbox $(mkRelDir "testlink") + let dst' = AbsP $ sandbox $(mkRelFile "testlink") + diagnoseFp src' `shouldReturn` Nonexistent + diagnoseFp dst' `shouldReturn` Nonexistent + ensureDir src + diagnoseFp src' `shouldReturn` IsDirectory + diagnoseFp dst' `shouldReturn` Nonexistent + -- Under test + performLinkDir src dst + diagnoseFp src' `shouldReturn` IsDirectory + diagnoseFp dst' `shouldReturn` IsLinkTo src' + removeDirRecur src + removeLink $ dropTrailingPathSeparator $ toFilePath dst + diagnoseFp src' `shouldReturn` Nonexistent + diagnoseFp dst' `shouldReturn` Nonexistent diff --git a/test/SuperUserSpark/Diagnose/Gen.hs b/test/SuperUserSpark/Diagnose/Gen.hs new file mode 100644 --- /dev/null +++ b/test/SuperUserSpark/Diagnose/Gen.hs @@ -0,0 +1,37 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module SuperUserSpark.Diagnose.Gen where + +import TestImport + +import SuperUserSpark.Bake.Gen () +import SuperUserSpark.Diagnose.Types +import SuperUserSpark.Compiler.Gen () +import SuperUserSpark.Language.Gen () + +instance GenUnchecked DiagnoseAssignment + +instance GenValid DiagnoseAssignment where + genValid = DiagnoseAssignment <$> genValid <*> genValid + +instance GenUnchecked DiagnoseSettings + +instance GenValid DiagnoseSettings where + genValid = DiagnoseSettings <$> genValid + +instance GenUnchecked DiagnoseError + +instance GenValid DiagnoseError + +instance GenUnchecked HashDigest + +instance GenValid HashDigest + +instance GenUnchecked Diagnostics + +instance GenValid Diagnostics + +instance GenUnchecked DiagnosedFp + +instance GenValid DiagnosedFp where + genValid = D <$> genValid <*> genValid <*> genValid diff --git a/test/SuperUserSpark/Diagnose/TestUtils.hs b/test/SuperUserSpark/Diagnose/TestUtils.hs new file mode 100644 --- /dev/null +++ b/test/SuperUserSpark/Diagnose/TestUtils.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE TemplateHaskell #-} + +module SuperUserSpark.Diagnose.TestUtils where + +import TestImport + +import SuperUserSpark.Bake.Gen () +import SuperUserSpark.Bake.Types +import SuperUserSpark.Check.Gen () +import SuperUserSpark.Check.Internal +import SuperUserSpark.Check.Types +import SuperUserSpark.CoreTypes +import SuperUserSpark.Diagnose.Types + + +-- TODO, the code should be able to handle 'genValid', but currenty it can't. +absPathIn :: Path Abs Dir -> Gen AbsP +absPathIn sandbox = + scale (+ 5) $ do + fp <- genListOf $ elements $ ['a' .. 'z'] ++ ['A' .. 'Z'] + case parseRelFile fp of + Nothing -> absPathIn sandbox + Just p -> pure $ AbsP $ sandbox p + +absFileIn :: Path Abs Dir -> Gen (Path Abs File, AbsP) +absFileIn sandbox = do + p <- absPathIn sandbox + pure (unAbsP p, p) + +absDirIn :: Path Abs Dir -> Gen (Path Abs Dir, AbsP) +absDirIn sandbox = do + p <- absPathIn sandbox + let u = toPath p + case parseAbsDir u of + Nothing -> absDirIn sandbox + Just ad -> pure (ad, p) diff --git a/test/SuperUserSpark/DiagnoseSpec.hs b/test/SuperUserSpark/DiagnoseSpec.hs new file mode 100644 --- /dev/null +++ b/test/SuperUserSpark/DiagnoseSpec.hs @@ -0,0 +1,270 @@ +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TemplateHaskell #-} + +module SuperUserSpark.DiagnoseSpec where + +import TestImport + +import Control.Monad (forM_) +import Data.Hashable +import System.FilePath (dropTrailingPathSeparator) +import System.Posix.Files + +import SuperUserSpark.Bake.Types +import SuperUserSpark.Check +import SuperUserSpark.Check.Gen () +import SuperUserSpark.Check.Internal +import SuperUserSpark.Check.TestUtils +import SuperUserSpark.Check.Types +import SuperUserSpark.Compiler.Types +import SuperUserSpark.CoreTypes +import SuperUserSpark.Diagnose +import SuperUserSpark.Diagnose.Gen () +import SuperUserSpark.Diagnose.Internal +import SuperUserSpark.Diagnose.TestUtils +import SuperUserSpark.Diagnose.Types +import SuperUserSpark.OptParse.Gen () +import SuperUserSpark.Parser.Gen () +import SuperUserSpark.Utils +import TestUtils + +spec :: Spec +spec = do + instanceSpec + diagnoseSpec + hashSpec + +instanceSpec :: Spec +instanceSpec = do + eqSpec @CheckSettings + genValidSpec @CheckSettings + eqSpec @Diagnostics + genValidSpec @Diagnostics + eqSpec @DiagnosedFp + genValidSpec @DiagnosedFp + eqSpec @DiagnosedDeployment + genValidSpec @DiagnosedDeployment + +diagnoseSpec :: Spec +diagnoseSpec = do + describe "formatDiagnoseError" $ + it "always produces valid strings" $ producesValid formatDiagnoseError + sandbox <- runIO $ resolveDir' "test_sandbox" + let setup = ensureDir sandbox + let teardown = removeDirRecur sandbox + beforeAll_ setup $ + afterAll_ teardown $ do + describe "diagnoseDeployment" $ do + it + "retains the filepaths and deploymentkind that it diagnoses for valid filepaths" $ do + forAll genValid $ \d@(Deployment (Directions srcs dst) kind) -> do + (Deployment (Directions dsrcs ddst) dkind) <- + diagnoseDeployment d + map diagnosedFilePath dsrcs `shouldBe` srcs + diagnosedFilePath ddst `shouldBe` dst + dkind `shouldBe` kind + pend + describe "diagnose" $ do + it "retains the filepath that it diagnoses for valid AbsPath's" $ do + forAll genValid $ \fp -> do + (D dfp _ _) <- diagnoseAbsP fp + dfp `shouldBe` fp + pend + describe "diagnoseFp" $ do + let expect s ls = do + rs <- + forM ls $ \(a, b) -> do + r <- diagnoseFp a + pure (a, r, b) + unless (all (\(a, r, b) -> r == b) rs) $ + let nice (a, r, b) = + unlines + [ unwords + [ "Unexpected results at stage" + , show s + ] + , unwords ["path:", show $ toPath a] + , unwords + [ "stripped:" + , show $ + (stripDir sandbox $ unAbsP a :: Maybe (Path Rel File)) + ] + , unwords ["expected:", show b] + , unwords ["real:", show r] + ] + in expectationFailure $ unlines $ map nice rs + it "figures out this link that points to something that exists" $ do + let file = sandbox $(mkRelFile "file") + let file' = AbsP file + let link = sandbox $(mkRelFile "link") + let link' = AbsP link + expect "before" [(file', Nonexistent), (link', Nonexistent)] + writeFile file "This is a test" + expect + "after file creation" + [(file', IsFile), (link', Nonexistent)] + createSymbolicLink (toFilePath file) (toFilePath link) + expect + "after link creation" + [(file', IsFile), (link', IsLinkTo file')] + removeLink $ toFilePath link + expect + "after link removal" + [(file', IsFile), (link', Nonexistent)] + removeFile file + expect + "after file removal" + [(file', Nonexistent), (link', Nonexistent)] + it + "figures out this link that points to something that does not exist" $ do + let file = sandbox $(mkRelFile "file") + let file' = AbsP file + let link = sandbox $(mkRelFile "link") + let link' = AbsP link + expect "before" [(file', Nonexistent), (link', Nonexistent)] + createSymbolicLink (toFilePath file) (toFilePath link) + expect + "after link creation" + [(file', Nonexistent), (link', IsLinkTo file')] + removeLink $ toFilePath link + expect "after" [(file', Nonexistent), (link', Nonexistent)] + it + "figures out that a thing in a nonexistent dir is nonexistent" $ do + let file = sandbox $(mkRelFile "nonexistent/and/file") + let file' = AbsP file + diagnoseFp file' `shouldReturn` Nonexistent + it "figures out a file" $ do + forAll (absFileIn sandbox) $ \(file, file') -> do + diagnoseFp file' `shouldReturn` Nonexistent + ensureDir $ parent file + writeFile file "This is a test" + diagnoseFp file' `shouldReturn` IsFile + removeFile file + diagnoseFp file' `shouldReturn` Nonexistent + it "figures out a directory" $ do + forAll (absDirIn sandbox) $ \(dir, dir') -> do + diagnoseFp dir' `shouldReturn` Nonexistent + ensureDir dir + diagnoseFp dir' `shouldReturn` IsDirectory + removeDirRecur dir + diagnoseFp dir' `shouldReturn` Nonexistent + it "figures out a symbolic link with an existent destination" $ do + forAll (absFileIn sandbox) $ \f@(file, file') -> + forAll (absFileIn sandbox `suchThat` (/= f)) $ \(link, link') -> do + expect + "before" + [(file', Nonexistent), (link', Nonexistent)] + writeFile file "This is a test" + expect + "after file creation" + [(file', IsFile), (link', Nonexistent)] + createSymbolicLink + (toFilePath file) + (toFilePath link) + expect + "after link creation" + [(file', IsFile), (link', IsLinkTo file')] + removeLink $ toFilePath link + expect + "after link removal" + [(file', IsFile), (link', Nonexistent)] + removeFile file + expect + "after" + [(file', Nonexistent), (link', Nonexistent)] + it "figures out a symbolic link with a nonexistent destination" $ do + forAll (absFileIn sandbox) $ \f@(file, file') -> + forAll (absFileIn sandbox `suchThat` (/= f)) $ \(link, link') -> do + expect + "before" + [(file', Nonexistent), (link', Nonexistent)] + createSymbolicLink + (toFilePath file) + (toFilePath link) + expect + "after link creation" + [(file', Nonexistent), (link', IsLinkTo file')] + removeLink $ toFilePath link + expect + "after" + [(file', Nonexistent), (link', Nonexistent)] + it "figures out that /dev/null is weird" $ do + diagnoseFp (AbsP $(mkAbsFile "/dev/null")) `shouldReturn` + IsWeird + it "figures out that /dev/random is weird" $ do + diagnoseFp (AbsP $(mkAbsFile "/dev/random")) `shouldReturn` + IsWeird + +checkDeploymentSpec :: Spec +checkDeploymentSpec = do + describe "checkDeployment" $ do + it "always produces valid check results" $ + producesValidsOnValids checkDeployment + it "says 'impossible' for deployments with an empty list of sources" $ do + forAll genUnchecked $ \dst -> + forAll genUnchecked $ \kind -> + shouldBeImpossible' $ Deployment (Directions [] dst) kind + it "says 'impossible' for deployments where all singles are impossible" $ do + forAll + (genValid `suchThat` + (\(Deployment (Directions 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 + forAll genValid $ \dd@(Deployment (Directions 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 "always produces valid check results" $ + producesValidsOnValids bestResult + it "says 'impossible' if all checkresults are impossible" $ do + forAll + (genValid `suchThat` all isImpossible) + shouldBeImpossibleDeployment + it "says 'done' if the first non-impossible in 'done'" $ do + forAll + (genValid `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 + (genValid `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 + (genValid `suchThat` + (any (not . isImpossible) &&& + (isReady . head . dropWhile isImpossible))) $ \dd -> + bestResult dd `shouldSatisfy` deploymentReadyToDeploy + +hashSpec :: Spec +hashSpec = do + tooManyFilesTest + +tooManyFilesTest :: Spec +tooManyFilesTest = do + sandbox <- runIO $ resolveDir' "test_sandbox" + let setup = ensureDir sandbox + let teardown = removeDirRecur sandbox + let aLot = 20000 :: Int + let setupALotOfFiles = do + forM_ [1 .. aLot] $ \i -> do + f <- parseRelFile $ "file" ++ show i + writeFile (sandbox f) $ "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 + sb <- resolveFile' "test_sandbox" + let d = AbsP sb + hashFilePath d `shouldNotReturn` HashDigest (hash ()) diff --git a/test/SuperUserSpark/EndToEnd/RegressionSpec.hs b/test/SuperUserSpark/EndToEnd/RegressionSpec.hs new file mode 100644 --- /dev/null +++ b/test/SuperUserSpark/EndToEnd/RegressionSpec.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE TemplateHaskell #-} + +module SuperUserSpark.EndToEnd.RegressionSpec + ( spec + ) where + +import TestImport + +import System.Directory +import System.Environment (withArgs) +import System.Exit (ExitCode(ExitFailure)) +import System.Posix.Files + +import SuperUserSpark +import SuperUserSpark.Utils + +spec :: Spec +spec = do + linkThenCopySpec + +linkThenCopySpec :: Spec +linkThenCopySpec = do + here <- runIO getCurrentDir + let sandbox = here $(mkRelDir "test_sandbox") + let setup = ensureDir sandbox + let teardown = removeDirRecur sandbox + beforeAll_ setup $ + afterAll_ teardown $ do + describe "link then copy regression" $ do + let runSpark args = do + putStrLn $ unwords $ "spark" : args + withArgs args spark + it + "ensures that deploy fails when there is already a link that points to the file that is being copied." $ + withCurrentDir sandbox $ do + let cf = sandbox $(mkRelFile "cardfile.sus") + let file = $(mkRelFile "file") + let from = sandbox $(mkRelDir "from") file + let to = sandbox $(mkRelDir "to") file + -- Set up the file + ensureDir (parent from) + writeFile from "contents" + -- Set up the first card file + writeFile + cf + "card link { kind link; into to; outof from; file }" + runSpark ["parse", toFilePath cf] + runSpark ["compile", toFilePath cf] + runSpark ["bake", toFilePath cf] + runSpark ["check", toFilePath cf] + runSpark ["deploy", toFilePath cf] + -- Set up the second card file + writeFile + cf + "card link { kind copy; into to; outof from; file }" + runSpark ["parse", toFilePath cf] + runSpark ["compile", toFilePath cf] + runSpark ["bake", toFilePath cf] + runSpark ["check", toFilePath cf] + runSpark ["deploy", toFilePath cf] `shouldThrow` + (\e -> + case e of + ExitFailure _ -> True + _ -> False) diff --git a/test/SuperUserSpark/EndToEndSpec.hs b/test/SuperUserSpark/EndToEndSpec.hs new file mode 100644 --- /dev/null +++ b/test/SuperUserSpark/EndToEndSpec.hs @@ -0,0 +1,85 @@ +module SuperUserSpark.EndToEndSpec + ( spec + ) where + +import TestImport hiding ((), removeFile, copyFile) + +import qualified Prelude as P (writeFile, readFile) + +import SuperUserSpark +import SuperUserSpark.Utils +import System.Directory +import System.Environment (withArgs) +import System.Exit (ExitCode(ExitSuccess)) +import System.FilePath.Posix (()) +import System.Posix.Files + +spec :: Spec +spec = do + helpTextSpec + regularWorkflowSpec + +helpTextSpec :: Spec +helpTextSpec = + describe "help text test" $ do + it "shows the help text without crashing" $ do + withArgs ["--help"] spark `shouldThrow` (== ExitSuccess) + +regularWorkflowSpec :: Spec +regularWorkflowSpec = do + here <- runIO getCurrentDirectory + let sandbox = here "test_sandbox" + let setup = createDirectoryIfMissing True sandbox + let teardown = removeDirectoryRecursive sandbox + let rsc = here "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 True "bash" + withCurrentDirectory "bash" $ do + P.writeFile "bash_aliases" "bash_aliases" + P.writeFile "bashrc" "bashrc" + P.writeFile "bash_profile" "bash_profile" + let down = do + removeFile cardfile + withCurrentDirectory sandbox $ do + removeDirectoryRecursive "bash" + beforeAll_ up $ + afterAll_ down $ do + it "parses correcty" $ do + withCurrentDirectory sandbox $ + withArgs ["parse", cardfile] spark `shouldReturn` + () + it "compiles correctly" $ do + let outfile = sandbox "bash.sus.res" + withCurrentDirectory sandbox $ + withArgs + ["compile", cardfile, "--output", outfile] + spark `shouldReturn` + () + actual <- P.readFile outfile + expected <- P.readFile bashrscres + unless (actual == expected) $ expectationFailure $ unlines ["Expected and actual differ:", expected, actual] + it "checks without exceptions" $ do + withCurrentDirectory sandbox $ + withArgs ["check", cardfile] spark `shouldReturn` + () + it "deploys correctly" $ + withCurrentDirectory sandbox $ do + withArgs ["deploy", cardfile] spark `shouldReturn` + () + let f1 = "subdir" ".bashrc" + f2 = "subdir" ".bash_aliases" + f3 = "subdir" ".bash_profile" + P.readFile f1 `shouldReturn` "bashrc" + P.readFile f2 `shouldReturn` "bash_aliases" + P.readFile f3 `shouldReturn` "bash_profile" + removeLink f1 + removeLink f2 + removeLink f3 diff --git a/test/SuperUserSpark/Language/Gen.hs b/test/SuperUserSpark/Language/Gen.hs new file mode 100644 --- /dev/null +++ b/test/SuperUserSpark/Language/Gen.hs @@ -0,0 +1,64 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module SuperUserSpark.Language.Gen where + +import TestImport + +import SuperUserSpark.CoreTypes +import SuperUserSpark.Language.Types + +instance GenUnchecked SparkFile where + genUnchecked = SparkFile <$> genUnchecked <*> genUnchecked + +instance GenValid SparkFile + +instance GenUnchecked Card where + genUnchecked = Card <$> genUnchecked <*> genUnchecked + +instance GenValid Card + +instance GenUnchecked Declaration where + genUnchecked = resize 5 $ sized go + where + go 0 = + oneof + [ SparkOff <$> genUnchecked + , Deploy <$> genUnchecked <*> genUnchecked <*> genUnchecked + , IntoDir <$> genUnchecked + , OutofDir <$> genUnchecked + , DeployKindOverride <$> genUnchecked + , Alternatives <$> genUnchecked + , Block <$> genUnchecked + ] + go n = + oneof + [ SparkOff <$> genUnchecked + , Deploy <$> genUnchecked <*> genUnchecked <*> genUnchecked + , IntoDir <$> genUnchecked + , OutofDir <$> genUnchecked + , DeployKindOverride <$> genUnchecked + , Alternatives <$> genUnchecked + , Block <$> listOf (go $ n - 1) + ] + +instance GenValid Declaration + +instance GenUnchecked DeploymentKind where + genUnchecked = elements [LinkDeployment, CopyDeployment] + +instance GenValid DeploymentKind + +instance GenUnchecked CardNameReference where + genUnchecked = CardNameReference <$> genUnchecked + +instance GenValid CardNameReference + +instance GenUnchecked CardFileReference where + genUnchecked = CardFileReference <$> genUnchecked <*> genUnchecked + +instance GenValid CardFileReference + +instance GenUnchecked CardReference where + genUnchecked = oneof [CardFile <$> genUnchecked, CardName <$> genUnchecked] + +instance GenValid CardReference diff --git a/test/SuperUserSpark/OptParse/Gen.hs b/test/SuperUserSpark/OptParse/Gen.hs new file mode 100644 --- /dev/null +++ b/test/SuperUserSpark/OptParse/Gen.hs @@ -0,0 +1,55 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module SuperUserSpark.OptParse.Gen where + +import TestImport + +import SuperUserSpark.OptParse.Types + +instance GenUnchecked Dispatch + +instance GenValid Dispatch + +instance GenUnchecked ParseArgs + +instance GenValid ParseArgs + +instance GenUnchecked CompileArgs + +instance GenValid CompileArgs + +instance GenUnchecked CompileFlags + +instance GenValid CompileFlags + +instance GenUnchecked BakeArgs + +instance GenValid BakeArgs + +instance GenUnchecked BakeFlags + +instance GenValid BakeFlags + +instance GenUnchecked CheckArgs + +instance GenValid CheckArgs + +instance GenUnchecked CheckFlags + +instance GenValid CheckFlags + +instance GenUnchecked DiagnoseArgs + +instance GenValid DiagnoseArgs + +instance GenUnchecked DiagnoseFlags + +instance GenValid DiagnoseFlags + +instance GenUnchecked DeployArgs + +instance GenValid DeployArgs + +instance GenUnchecked DeployFlags + +instance GenValid DeployFlags diff --git a/test/SuperUserSpark/Parser/Gen.hs b/test/SuperUserSpark/Parser/Gen.hs new file mode 100644 --- /dev/null +++ b/test/SuperUserSpark/Parser/Gen.hs @@ -0,0 +1,85 @@ +module SuperUserSpark.Parser.Gen where + +import TestImport + +import Data.List (isSuffixOf) + +generateNormalCharacter :: Gen Char +generateNormalCharacter = + elements $ ['a' .. 'z'] ++ ['A' .. 'Z'] ++ ['0' .. '1'] + +generateWord :: Gen String +generateWord = listOf1 generateNormalCharacter + +generateTab :: Gen Char +generateTab = return '\t' + +generateSpace :: Gen Char +generateSpace = return ' ' + +generateLineFeed :: Gen Char +generateLineFeed = return '\n' + +generateCarriageReturn :: Gen Char +generateCarriageReturn = return '\r' + +generateLineSpace :: Gen String +generateLineSpace = listOf $ oneof [generateTab, generateSpace] + +generateWhiteSpace :: Gen String +generateWhiteSpace = + listOf $ + oneof [generateTab, generateSpace, generateLineFeed, generateCarriageReturn] + +generateWords :: Gen String +generateWords = fmap unwords $ listOf1 generateWord + +generateEol :: Gen String +generateEol = elements ["\n", "\r", "\r\n"] + +twice :: Gen a -> Gen (a, a) +twice gen = (,) <$> gen <*> gen + +trice :: Gen a -> Gen (a, a, a) +trice gen = (,,) <$> gen <*> gen <*> gen + +generateCardName :: Gen (String, String) +generateCardName = oneof [generateQuotedIdentifier, generatePlainIdentifier] + +generateIdentifier :: Gen (String, String) +generateIdentifier = oneof [generatePlainIdentifier, generateQuotedIdentifier] + +generateQuotedIdentifier :: Gen (String, String) +generateQuotedIdentifier = do + w <- generateWord + return $ ("\"" ++ w ++ "\"", w) + +generatePlainIdentifier :: Gen (String, String) +generatePlainIdentifier = do + w <- generateWord + return $ (w, w) + +generateFilePath :: Gen (FilePath, FilePath) +generateFilePath = + generateIdentifier `suchThat` (\(_, f) -> not $ "/" `isSuffixOf` f) + +generateDirectory :: Gen (FilePath, FilePath) +generateDirectory = generateFilePath + +generateComment :: Gen (String, String) +generateComment = oneof [generateLineComment, generateBlockComment] + +generateLineComment :: Gen (String, String) +generateLineComment = do + ws <- generateWords + let ws' = "#" ++ ws ++ "\n" + return (ws', ws) + +generateBlockComment :: Gen (String, String) +generateBlockComment = do + ws <- generateWords + let ws' = "[[" ++ ws ++ "]]" + return (ws', ws) + +generateDeploymentKindSymbol :: Gen String +generateDeploymentKindSymbol = elements ["l->", "c->", "->"] diff --git a/test/SuperUserSpark/Parser/TestUtils.hs b/test/SuperUserSpark/Parser/TestUtils.hs new file mode 100644 --- /dev/null +++ b/test/SuperUserSpark/Parser/TestUtils.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE TemplateHaskell #-} + +module SuperUserSpark.Parser.TestUtils where + +import TestImport hiding (succeeds) + +import Data.Either (isRight) +import SuperUserSpark.Parser.Internal +import Text.Parsec +import Text.Parsec.String + +shouldSucceed + :: (Show a, Eq a) + => Parser a -> String -> IO () +shouldSucceed parser input = input `shouldSatisfy` succeeds parser + +shouldFail + :: (Show a, Eq a) + => Parser a -> String -> IO () +shouldFail parser input = input `shouldNotSatisfy` succeeds parser + +succeeds :: Parser a -> String -> Bool +succeeds parser = succeedsWithLeftover $ parser >> eof + +succeedsWithLeftover :: Parser a -> String -> Bool +succeedsWithLeftover parser input = isRight $ parseWithoutSource parser input + +succeedsAnywhere :: Parser a -> String -> Bool +succeedsAnywhere p s = or $ map (succeedsWithLeftover p) (tails s) + where + tails :: [a] -> [[a]] + tails [] = [[]] + tails ass@(_:as) = ass : tails as + +fails :: Parser a -> String -> Bool +fails parser input = not $ succeeds parser input + +testInputSource :: Path Abs File +testInputSource = $(mkAbsFile "/Test/input/file") + +parseShouldSucceedAs + :: (Show a, Eq a) + => Parser a -> String -> a -> IO () +parseShouldSucceedAs parser input a = + parseFromSource parser testInputSource input `shouldBe` Right a + +parseShouldBe + :: (Show a, Eq a) + => Parser a -> String -> Either ParseError a -> IO () +parseShouldBe parser input result = + parseFromSource parser testInputSource input `shouldBe` result + +parseWithoutSource :: Parser a -> String -> Either ParseError a +parseWithoutSource parser input = parseFromSource parser testInputSource input diff --git a/test/SuperUserSpark/ParserSpec.hs b/test/SuperUserSpark/ParserSpec.hs new file mode 100644 --- /dev/null +++ b/test/SuperUserSpark/ParserSpec.hs @@ -0,0 +1,528 @@ +{-# LANGUAGE TypeApplications #-} + +module SuperUserSpark.ParserSpec where + +import TestImport hiding (succeeds) + +import Data.Either (isLeft, isRight) +import Data.List (intercalate) +import Text.Parsec + +import SuperUserSpark.CoreTypes +import SuperUserSpark.Language.Gen () +import SuperUserSpark.Language.Types +import SuperUserSpark.Parser.Gen +import SuperUserSpark.Parser.Internal +import SuperUserSpark.Parser.TestUtils +import TestUtils + +spec :: Spec +spec = + parallel $ do + instanceSpec + blankspaceParserTests + enclosingCharacterTests + delimiterTests + identifierParserTests + commentParserTests + pathParserTests + declarationParserTests + parserBlackBoxTests + toplevelParserTests + +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 + +instanceSpec :: Spec +instanceSpec = do + eqSpec @Card + genValidSpec @Card + eqSpec @Declaration + genValidSpec @Declaration + eqSpec @CardNameReference + genValidSpec @CardNameReference + eqSpec @CardFileReference + genValidSpec @CardFileReference + eqSpec @CardReference + genValidSpec @CardReference + eqSpec @SparkFile + genValidSpec @SparkFile + +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" $ + 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 pti = shouldSucceed plainIdentifier + it "succeeds for these examples" $ do + pti "bash" + pti "card" + pti ".bashrc" + pti "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 pti i = parseShouldSucceedAs quotedIdentifier ("\"" ++ i ++ "\"") i + it "succeeds for these examples" $ do + pti "bashrc" + pti "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 + testRecoursesDir <- runIO $ resolveDir' "test_resources" + describe "Correct succesful parse examples" $ do + let dirs = + map + (testRecoursesDir ) + [shouldParseDir, shouldCompileDir, shouldNotCompileDir] + forFileInDirss dirs $ + concerningContents $ \f contents -> do + it (toFilePath f) $ + parseCardFile f contents `shouldSatisfy` isRight + describe "Correct unsuccesfull parse examples" $ do + let dirs = map (testRecoursesDir ) [shouldNotParseDir] + forFileInDirss dirs $ + concerningContents $ \f contents -> do + it (toFilePath f) $ + parseCardFile f contents `shouldSatisfy` isLeft + +toplevelParserTests :: Spec +toplevelParserTests = do + describe "sparkFile" $ do + it "Only ever produces valid SparkFile's" $ + validIfSucceeds2 parseCardFile + pend + describe "resetPosition" $ do pend diff --git a/test/SuperUserSpark/PreCompiler/Gen.hs b/test/SuperUserSpark/PreCompiler/Gen.hs new file mode 100644 --- /dev/null +++ b/test/SuperUserSpark/PreCompiler/Gen.hs @@ -0,0 +1,12 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module SuperUserSpark.PreCompiler.Gen where + +import TestImport + +import SuperUserSpark.Language.Gen () +import SuperUserSpark.PreCompiler.Types + +instance GenUnchecked PreCompileError + +instance GenValid PreCompileError diff --git a/test/TestImport.hs b/test/TestImport.hs new file mode 100644 --- /dev/null +++ b/test/TestImport.hs @@ -0,0 +1,32 @@ +module TestImport + ( module X + ) where + +import Prelude as X hiding (writeFile, readFile, putStr,putStrLn, appendFile) + +import Path as X +import Path.IO as X + +import Control.Monad as X +import Control.Monad.Except as X +import Control.Monad.IO.Class as X (MonadIO(..)) +import Control.Monad.Identity as X +import Control.Monad.Reader as X +import Control.Monad.State as X +import Control.Monad.Writer as X + +import Debug.Trace as X + +import Data.IOString as X + +import Test.Hspec as X +import Test.QuickCheck as X + +import Data.GenValidity as X +import Data.GenValidity.Path as X () +import Data.Validity as X () +import Data.Validity.Path as X () +import Test.Validity as X +import Test.Validity.Aeson as X + +import System.FilePath as X (dropTrailingPathSeparator) diff --git a/test/TestUtils.hs b/test/TestUtils.hs new file mode 100644 --- /dev/null +++ b/test/TestUtils.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE TemplateHaskell #-} + +module TestUtils where + +import TestImport + +shouldParseDir :: Path Rel Dir +shouldParseDir = $(mkRelDir "shouldParseDir") + +shouldNotParseDir :: Path Rel Dir +shouldNotParseDir = $(mkRelDir "shouldNotParseDir") + +shouldCompileDir :: Path Rel Dir +shouldCompileDir = $(mkRelDir "shouldCompileDir") + +shouldNotCompileDir :: Path Rel Dir +shouldNotCompileDir = $(mkRelDir "shouldNotCompileDir") + +concerningContents :: (Path Abs File -> String -> SpecWith a) + -> (Path Abs File -> SpecWith a) +concerningContents func file = (runIO $ readFile file) >>= func file + +forFileInDirss :: [Path Abs Dir] -> (Path Abs File -> SpecWith a) -> SpecWith a +forFileInDirss [] _ = return () +forFileInDirss dirs func = + forM_ dirs $ \dir -> do + exists <- runIO $ doesDirExist dir + when exists $ do + files <- runIO $ snd <$> listDirRecur dir + forM_ files func + +pend :: SpecWith () +pend = it "is still missing some tests" pending