diff --git a/Config/Dyre.hs b/Config/Dyre.hs --- a/Config/Dyre.hs +++ b/Config/Dyre.hs @@ -18,89 +18,83 @@ but it has no impact whatsoever on the rest of the library whether it is used or not. -A full example of using Dyre's recompilation and relaunching features -is as follows: +A full example of using most of Dyre's major features is as follows: ->-- DyreExample.hs -- ->module DyreExample where -> ->import qualified Config.Dyre as Dyre -> ->import Config.Dyre.Relaunch ->import System.IO -> ->data Config = Config { message :: String, errorMsg :: Maybe String } ->data State = State { bufferLines :: [String] } deriving (Read, Show) -> ->defaultConfig :: Config ->defaultConfig = Config "Dyre Example v0.1" Nothing -> ->showError :: Config -> String -> Config ->showError cfg msg = cfg { errorMsg = Just msg } -> ->realMain Config{message = message, errorMsg = errorMsg } = do -> (State buffer) <- restoreTextState $ State [] -> case errorMsg of -> Nothing -> return () -> Just em -> putStrLn $ "Error: " ++ em -> putStrLn message -> mapM putStrLn . reverse $ buffer -> putStr "> " >> hFlush stdout -> input <- getLine -> case input of -> "exit" -> return () -> "quit" -> return () -> other -> relaunchWithTextState (State $ other:buffer) Nothing -> ->dyreExample = Dyre.wrapMain $ Dyre.defaultParams -> { Dyre.projectName = "dyreExample" -> , Dyre.realMain = realMain -> , Dyre.showError = showError -> } + -- DyreExample.hs -- + module DyreExample where + import qualified Config.Dyre as Dyre + import Config.Dyre.Relaunch + + import System.IO + + data Config = Config { message :: String, errorMsg :: Maybe String } + data State = State { bufferLines :: [String] } deriving (Read, Show) + + defaultConfig :: Config + defaultConfig = Config "Dyre Example v0.1" Nothing + + showError :: Config -> String -> Config + showError cfg msg = cfg { errorMsg = Just msg } + + realMain Config{message = message, errorMsg = errorMsg } = do + (State buffer) <- restoreTextState $ State [] + case errorMsg of + Nothing -> return () + Just em -> putStrLn $ "Error: " ++ em + putStrLn message + mapM putStrLn . reverse $ buffer + putStr "> " >> hFlush stdout + input <- getLine + case input of + "exit" -> return () + "quit" -> return () + other -> relaunchWithTextState (State $ other:buffer) Nothing + + dyreExample = Dyre.wrapMain $ Dyre.defaultParams + { Dyre.projectName = "dyreExample" + , Dyre.realMain = realMain + , Dyre.showError = showError + } + Notice that all of the program logic is contained in the 'DyreExample' -module. The main module of the program is absolutely trivial. +module. The main module of the program is absolutely trivial, being +essentially just the default configuration for the program: ->-- Main.hs -- ->module Main where ->import DyreExample ->main = dyreExample defaultConfig + -- Main.hs -- + import DyreExample + main = dyreExample defaultConfig -When reading the above program, bear in mind exactly how much of the +When reading the above program, notice that the majority of the code is simply *program logic*. Dyre is designed to intelligently -handle recompilation with a bare minimum of program modification. +handle recompilation with a minimum of programmer work. Some mention should be made of Dyre's defaults. The 'defaultParams' structure used in the example defines reasonable default values for -several configuration items. In the absence of any other definitions, -Dyre will default to outputting status messages to stderr, not hiding -any packages during compilation, and passing no special options to GHC. +most configuration items. The three elements defined above are the +only elements that must be overridden. For documentation of the +parameters, consult the 'Config.Dyre.Params' module. -Also, Dyre will expect configuration files to be placed at the path -'$XDG_CONFIG_HOME//.hs', and it will store cache files in -the '$XDG_CACHE_HOME//' directory. The 'System.Environment.XDG' -module will be used to determine these paths, so refer to it for -behaviour on Windows platforms. +In the absence of any customization, Dyre will search for configuration +files in '$XDG_CONFIG_HOME//.hs', and will store +cache files in '$XDG_CACHE_HOME//' directory. The module +'System.Environment.XDG' is used for this purpose, which also provides +analogous behaviour on Windows. -} module Config.Dyre ( wrapMain, Params(..), defaultParams ) where import System.IO ( hPutStrLn, stderr ) -import System.Directory ( doesFileExist ) +import System.Directory ( doesFileExist, removeFile ) +import System.Environment ( getArgs ) import Config.Dyre.Params ( Params(..) ) -import Config.Dyre.Compile ( customCompile ) +import Config.Dyre.Compile ( customCompile, getErrorPath, getErrorString ) import Config.Dyre.Compat ( customExec ) -import Config.Dyre.Options ( getReconf, getDebug, withDyreOptions ) +import Config.Dyre.Options ( getForceReconf, getDenyReconf, getDebug, withDyreOptions ) import Config.Dyre.Paths ( getPaths, maybeModTime ) --- | A set of reasonable defaults for configuring Dyre. If the minimal set of --- fields are modified, the program will use the XDG-defined locations for --- configuration and cache files (see 'System.Environment.XDG.BaseDir' for --- details), pass no special options to GHC, and will output status messages --- to stderr. --- --- The fields that will have to be filled are 'projectName', 'realMain', and --- 'showError' +-- | A set of reasonable defaults for configuring Dyre. The fields that +-- have to be filled are 'projectName', 'realMain', and 'showError'. defaultParams :: Params cfgType defaultParams = Params { projectName = undefined @@ -134,23 +128,44 @@ tempTime <- maybeModTime tempBinary confTime <- maybeModTime configFile + let confExists = confTime /= Nothing + -- If there's a config file, and the temp binary is older than something -- else, or we were specially told to recompile, then we should recompile. - let confExists = confTime /= Nothing - forceReconf <- getReconf - errors <- if confExists && - (tempTime < confTime || tempTime < thisTime || forceReconf) - then customCompile params - else return Nothing + denyReconf <- getDenyReconf + forceReconf <- getForceReconf + if not denyReconf && confExists && + (tempTime < confTime || tempTime < thisTime || forceReconf) + then customCompile params + else return () + -- If there's a custom binary and we're not it, run it. Otherwise -- just launch the main function, reporting errors if appropriate. -- Also we don't want to use a custom binary if the conf file is -- gone. + errorData <- getErrorString params customExists <- doesFileExist tempBinary if confExists && customExists && (thisBinary /= tempBinary) - then do statusOut params $ "Launching custom binary '" ++ tempBinary ++ "'\n" - customExec tempBinary Nothing - else realMain params $ case errors of - Nothing -> cfg - Just er -> (showError params) cfg er + then launchSub errorData tempBinary + else enterMain errorData + where launchSub errorData tempBinary = do + statusOut params $ "Launching custom binary " ++ tempBinary ++ "\n" + -- Deny reconfiguration if a compile already failed. + arguments <- case errorData of + Nothing -> getArgs + Just _ -> ("--deny-reconf":) `fmap` getArgs + -- Execute + customExec tempBinary $ Just arguments + enterMain errorData = do + -- Show the error data if necessary + let mainConfig = case errorData of + Nothing -> cfg + Just ed -> showError params cfg ed + -- Remove the error file if it exists + errorFile <- getErrorPath params + errorExists <- doesFileExist errorFile + if errorExists then removeFile errorFile + else return () + -- Enter the main program + realMain params mainConfig diff --git a/Config/Dyre/Compile.hs b/Config/Dyre/Compile.hs --- a/Config/Dyre/Compile.hs +++ b/Config/Dyre/Compile.hs @@ -2,7 +2,7 @@ Compiling the custom executable. The majority of the code actually deals with error handling, and not the compilation itself /per se/. -} -module Config.Dyre.Compile ( customCompile ) where +module Config.Dyre.Compile ( customCompile, getErrorPath, getErrorString ) where import System.IO ( openFile, hClose, IOMode(..) ) import System.Exit ( ExitCode(..) ) @@ -16,16 +16,35 @@ import Config.Dyre.Paths ( getPaths ) import Config.Dyre.Params ( Params(..) ) +-- | Return the path to the error file. +getErrorPath :: Params cfgType -> IO FilePath +getErrorPath params = do + (_,_,_, cacheDir) <- getPaths params + return $ cacheDir "errors.log" + +-- | If the error file exists and actually has some contents, return +-- 'Just' the error string. Otherwise return 'Nothing'. +getErrorString :: Params cfgType -> IO (Maybe String) +getErrorString params = do + errorPath <- getErrorPath params + errorsExist <- doesFileExist errorPath + if not errorsExist + then return Nothing + else do errorData <- readFile errorPath + if errorData == "" + then return Nothing + else return . Just $ errorData + -- | Attempts to compile the configuration file. Will return a string -- containing any compiler output. -customCompile :: Params cfgType -> IO (Maybe String) +customCompile :: Params cfgType -> IO () customCompile params@Params{statusOut = output} = do (thisBinary, tempBinary, configFile, cacheDir) <- getPaths params output $ "Configuration '" ++ configFile ++ "' changed. Recompiling." createDirectoryIfMissing True cacheDir -- Compile occurs in here - let errFile = cacheDir "errors.log" + errFile <- getErrorPath params result <- bracket (openFile errFile WriteMode) hClose $ \errHandle -> do ghcOpts <- makeFlags params configFile tempBinary cacheDir ghcProc <- runProcess ghc ghcOpts (Just cacheDir) Nothing @@ -36,16 +55,6 @@ if result /= ExitSuccess then output $ "Error occurred while loading configuration file." else output $ "Program reconfiguration successful." - - -- If the error file exists and actually has some contents, return - -- 'Just' the error string. Otherwise return 'Nothing'. - errorsExist <- doesFileExist errFile - if not errorsExist - then return Nothing - else do errors <- readFile errFile - if errors == "" - then return Nothing - else return . Just $ errors -- | Assemble the arguments to GHC so everything compiles right. makeFlags :: Params cfgType -> FilePath -> FilePath -> FilePath -> IO [String] diff --git a/Config/Dyre/Options.hs b/Config/Dyre/Options.hs --- a/Config/Dyre/Options.hs +++ b/Config/Dyre/Options.hs @@ -19,7 +19,8 @@ module Config.Dyre.Options ( withDyreOptions , customOptions - , getReconf + , getDenyReconf + , getForceReconf , getDebug , getMasterBinary , getStatePersist @@ -52,6 +53,7 @@ -- Load the other important arguments into IO storage. storeFlag args "--dyre-state-persist=" "persistState" putValue "dyre" "forceReconf" $ "--force-reconf" `elem` args + putValue "dyre" "denyReconf" $ "--deny-reconf" `elem` args putValue "dyre" "debugMode" $ "--dyre-debug" `elem` args -- We filter the arguments, so now Dyre's arguments 'vanish' @@ -61,9 +63,14 @@ -- | Get the value of the '--force-reconf' flag, which is used -- to force a recompile of the custom configuration. -getReconf :: IO Bool -getReconf = getDefaultValue "dyre" "forceReconf" False +getForceReconf :: IO Bool +getForceReconf = getDefaultValue "dyre" "forceReconf" False +-- | Get the value of the '--deny-reconf' flag, which disables +-- recompilation. This overrides "--force-reconf", too. +getDenyReconf :: IO Bool +getDenyReconf = getDefaultValue "dyre" "denyReconf" False + -- | Get the value of the '--dyre-debug' flag, which is used -- to debug a program without installation. Specifically, -- it forces the application to use './cache/' as the cache @@ -119,5 +126,6 @@ -- | The array of all arguments that Dyre recognizes. Used to -- make sure none of them are visible past 'withDyreOptions' dyreArgs :: [String] -dyreArgs = [ "--force-reconf", "--dyre-state-persist" - , "--dyre-debug", "--dyre-master-binary" ] +dyreArgs = [ "--force-reconf", "--deny-reconf" + , "--dyre-state-persist", "--dyre-debug" + , "--dyre-master-binary" ] diff --git a/Tests/README.mkd b/Tests/README.mkd new file mode 100644 --- /dev/null +++ b/Tests/README.mkd @@ -0,0 +1,11 @@ +Dyre Test Suite +=============== + +It's hard to design an automated testing system which can cope with a +program that recompiles itself on the fly, much less test the logic +behind those recompilations. + +As a result, Dyre's tests are very high-level. They consist of a set of +source files and a shell script which will compile and run the resulting +binary. Test success is determined entirely based on the output of the +programs. diff --git a/Tests/allTests.sh b/Tests/allTests.sh new file mode 100644 --- /dev/null +++ b/Tests/allTests.sh @@ -0,0 +1,16 @@ +#!/bin/sh + +# Run all test scripts for Dyre. + +for TESTDIR in `find . -mindepth 1 -type d`; do + cd $TESTDIR + TEST_RESULT=`./runTest.sh` + if [ "$TEST_RESULT" != 'Passed' ]; then + echo "$TEST_RESULT in test $TESTDIR" + rm -r working + exit 1 + fi + cd .. +done + +echo 'Passed' diff --git a/Tests/basic/BasicTest.hs b/Tests/basic/BasicTest.hs new file mode 100644 --- /dev/null +++ b/Tests/basic/BasicTest.hs @@ -0,0 +1,31 @@ +module BasicTest where + +import qualified Config.Dyre as Dyre + +import Config.Dyre.Relaunch +import System.IO + +data Config = Config { message :: String, errorMsg :: Maybe String } + +defaultConfig :: Config +defaultConfig = Config "Basic Test Version 1.0" Nothing + +showError :: Config -> String -> Config +showError cfg msg = cfg { errorMsg = Just msg } + +realMain Config{message = message, errorMsg = errorMsg } = do + case errorMsg of + Just em -> putStrLn "Compile Error" + Nothing -> do + state <- restoreTextState 1 + if state < 3 + then relaunchWithTextState (state + 1) Nothing + else return () + putStrLn $ message ++ " - " ++ show state + +basicTest = Dyre.wrapMain $ Dyre.defaultParams + { Dyre.projectName = "basicTest" + , Dyre.realMain = realMain + , Dyre.showError = showError + , Dyre.statusOut = const . return $ () + } diff --git a/Tests/basic/Main.hs b/Tests/basic/Main.hs new file mode 100644 --- /dev/null +++ b/Tests/basic/Main.hs @@ -0,0 +1,2 @@ +import BasicTest +main = basicTest defaultConfig diff --git a/Tests/basic/badConfig.hs b/Tests/basic/badConfig.hs new file mode 100644 --- /dev/null +++ b/Tests/basic/badConfig.hs @@ -0,0 +1,2 @@ +import BasicTest +main = basicTest $ defaultConfig { message = "Basic Test Version 3.0 } diff --git a/Tests/basic/goodConfig.hs b/Tests/basic/goodConfig.hs new file mode 100644 --- /dev/null +++ b/Tests/basic/goodConfig.hs @@ -0,0 +1,2 @@ +import BasicTest +main = basicTest $ defaultConfig { message = "Basic Test Version 2.0" } diff --git a/Tests/basic/runTest.sh b/Tests/basic/runTest.sh new file mode 100644 --- /dev/null +++ b/Tests/basic/runTest.sh @@ -0,0 +1,41 @@ +#!/bin/sh + +# Tests basic compiling and running. +# Tests state persistence across restarts. +# Tests custom configuration recompilation. +# Tests restarting a custom configuration. +# Tests compilation error reporting. + +# Assert the equality of two strings. +function assert() { + if [ "$1" != "$2" ]; then + echo "Failed test $3"; + exit 1; + fi +} + +### SETUP ### +mkdir working +cd working + +### TEST A ### +cp ../BasicTest.hs ../Main.hs . +ghc --make Main.hs -o basic 2> /dev/null +OUTPUT_A=`./basic --dyre-debug` +assert "$OUTPUT_A" "Basic Test Version 1.0 - 3" "A" + +### TEST B ### +cp ../goodConfig.hs basicTest.hs +OUTPUT_B=`./basic --dyre-debug` +assert "$OUTPUT_B" "Basic Test Version 2.0 - 3" "B" + +### TEST C ### +sleep 1 +cp ../badConfig.hs basicTest.hs +OUTPUT_C=`./basic --dyre-debug` +assert "$OUTPUT_C" "Compile Error" "C" + +### TEARDOWN ### +echo "Passed" +cd .. +rm -r working diff --git a/Tests/config-check/ConfigCheckTest.hs b/Tests/config-check/ConfigCheckTest.hs new file mode 100644 --- /dev/null +++ b/Tests/config-check/ConfigCheckTest.hs @@ -0,0 +1,19 @@ +module ConfigCheckTest where + +import qualified Config.Dyre as Dyre +import System.IO + +configCheckMain = Dyre.wrapMain $ Dyre.defaultParams + { Dyre.projectName = "configCheckTest" + , Dyre.realMain = putStrLn + , Dyre.showError = const + , Dyre.statusOut = const . return $ () + } + +configCheckTest = Dyre.wrapMain $ Dyre.defaultParams + { Dyre.projectName = "configCheckTest" + , Dyre.realMain = putStrLn + , Dyre.showError = const + , Dyre.statusOut = const . return $ () + , Dyre.configCheck = False + } diff --git a/Tests/config-check/Main.hs b/Tests/config-check/Main.hs new file mode 100644 --- /dev/null +++ b/Tests/config-check/Main.hs @@ -0,0 +1,2 @@ +import ConfigCheckTest +main = configCheckMain "main" diff --git a/Tests/config-check/configCheckTestA.hs b/Tests/config-check/configCheckTestA.hs new file mode 100644 --- /dev/null +++ b/Tests/config-check/configCheckTestA.hs @@ -0,0 +1,2 @@ +import ConfigCheckTest +main = configCheckTest "custom-a" diff --git a/Tests/config-check/configCheckTestB.hs b/Tests/config-check/configCheckTestB.hs new file mode 100644 --- /dev/null +++ b/Tests/config-check/configCheckTestB.hs @@ -0,0 +1,2 @@ +import ConfigCheckTest +main = configCheckTest "custom-b" diff --git a/Tests/config-check/runTest.sh b/Tests/config-check/runTest.sh new file mode 100644 --- /dev/null +++ b/Tests/config-check/runTest.sh @@ -0,0 +1,34 @@ +#!/bin/sh + +# Tests Dyre's ability to recompile a custom configuration +# upon relaunch, and restore the state again after. + +# Assert the equality of two strings. +function assert() { + if [ "$1" != "$2" ]; then + echo "Failed test $3"; + exit 1; + fi +} + +mkdir working +cd working + +### TEST A ### +cp ../ConfigCheckTest.hs ../Main.hs . +cp ../configCheckTestA.hs ./configCheckTest.hs +ghc --make Main.hs -o configCheck 2> /dev/null +OUTPUT_A=`./configCheck --dyre-debug` +assert "$OUTPUT_A" "custom-a" "A" + +sleep 1 + +### TEST B ### +cp ../configCheckTestB.hs ./configCheckTest.hs +mv cache/configCheckTest* configCheck +OUTPUT_B=`./configCheck --dyre-debug` +assert "$OUTPUT_B" "custom-a" "B" + +echo "Passed" +cd .. +rm -r working diff --git a/Tests/recompile-relaunch/Main.hs b/Tests/recompile-relaunch/Main.hs new file mode 100644 --- /dev/null +++ b/Tests/recompile-relaunch/Main.hs @@ -0,0 +1,2 @@ +import RecompileRelaunchTest +main = recompileRelaunchTest "Testing.." diff --git a/Tests/recompile-relaunch/RecompileRelaunchTest.hs b/Tests/recompile-relaunch/RecompileRelaunchTest.hs new file mode 100644 --- /dev/null +++ b/Tests/recompile-relaunch/RecompileRelaunchTest.hs @@ -0,0 +1,18 @@ +module RecompileRelaunchTest where + +import qualified Config.Dyre as Dyre +import Config.Dyre.Relaunch +import System.IO + +realMain message = do + state <- restoreTextState False + putStr message >> hFlush stdout + if state then putStrLn "" + else relaunchWithTextState True Nothing + +recompileRelaunchTest = Dyre.wrapMain $ Dyre.defaultParams + { Dyre.projectName = "recompileRelaunchTest" + , Dyre.realMain = realMain + , Dyre.showError = const + , Dyre.statusOut = const . return $ () + } diff --git a/Tests/recompile-relaunch/recompileRelaunchTest.hs b/Tests/recompile-relaunch/recompileRelaunchTest.hs new file mode 100644 --- /dev/null +++ b/Tests/recompile-relaunch/recompileRelaunchTest.hs @@ -0,0 +1,2 @@ +import RecompileRelaunchTest +main = recompileRelaunchTest "..Successful" diff --git a/Tests/recompile-relaunch/runTest.sh b/Tests/recompile-relaunch/runTest.sh new file mode 100644 --- /dev/null +++ b/Tests/recompile-relaunch/runTest.sh @@ -0,0 +1,29 @@ +#!/bin/sh + +# Tests Dyre's ability to recompile a custom configuration +# upon relaunch, and restore the state again after. + +# Assert the equality of two strings. +function assert() { + if [ "$1" != "$2" ]; then + echo "Failed test $3"; + exit 1; + fi +} + +mkdir working +cd working + +### TEST A ### +cp ../RecompileRelaunchTest.hs ../Main.hs ../recompileRelaunchTest.hs . +ghc --make Main.hs -o recompileRelaunch 2> /dev/null +OUTPUT_A=`./recompileRelaunch --dyre-debug --deny-reconf` +assert "$OUTPUT_A" "Testing....Successful" "A" + +### TEST B ### +OUTPUT_B=`./recompileRelaunch --dyre-debug --deny-reconf` +assert "$OUTPUT_B" "..Successful..Successful" "B" + +echo "Passed" +cd .. +rm -r working diff --git a/dyre.cabal b/dyre.cabal --- a/dyre.cabal +++ b/dyre.cabal @@ -1,5 +1,5 @@ name: dyre -version: 0.7.3 +version: 0.8.0 category: Development, Configuration synopsis: Dynamic reconfiguration in Haskell @@ -22,6 +22,16 @@ build-type: Simple cabal-version: >= 1.6 + +extra-source-files: + Tests/README.mkd + Tests/allTests.sh + Tests/basic/*.hs + Tests/basic/*.sh + Tests/config-check/*.hs + Tests/config-check/*.sh + Tests/recompile-relaunch/*.hs + Tests/recompile-relaunch/*.sh library exposed-modules: Config.Dyre,