dyre-0.8.12/0000755000000000000000000000000012320602301010720 5ustar0000000000000000dyre-0.8.12/dyre.cabal0000644000000000000000000000331212320602301012646 0ustar0000000000000000name: dyre version: 0.8.12 category: Development, Configuration synopsis: Dynamic reconfiguration in Haskell description: Dyre implements dynamic reconfiguration facilities after the style of Xmonad. Dyre aims to be as simple as possible without sacrificing features, and places an emphasis on simplicity of integration with an application. A full introduction with a complete example project can be found in the documentation for 'Config.Dyre' homepage: http://github.com/willdonnelly/dyre bug-reports: http://github.com/willdonnelly/dyre/issues stability: beta author: Will Donnelly maintainer: Will Donnelly copyright: (c) 2011 Will Donnelly license: BSD3 license-file: LICENSE 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, Config.Dyre.Paths, Config.Dyre.Compat, Config.Dyre.Params, Config.Dyre.Options, Config.Dyre.Compile, Config.Dyre.Relaunch build-depends: base >= 4 && < 5, process, filepath, directory, ghc-paths, time, binary, executable-path, xdg-basedir, io-storage if os(windows) build-depends: Win32 else build-depends: unix source-repository head type: git location: git://github.com/willdonnelly/dyre.git dyre-0.8.12/LICENSE0000644000000000000000000000275312320602301011734 0ustar0000000000000000Copyright (c) 2009, Will Donnelly All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of the software nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. dyre-0.8.12/Setup.hs0000644000000000000000000000011212320602301012346 0ustar0000000000000000#!/usr/bin/env runhaskell import Distribution.Simple main = defaultMain dyre-0.8.12/Tests/0000755000000000000000000000000012320602301012022 5ustar0000000000000000dyre-0.8.12/Tests/allTests.sh0000755000000000000000000000043112320602301014152 0ustar0000000000000000#!/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" exit 1 fi cd .. done echo 'Passed' dyre-0.8.12/Tests/README.mkd0000644000000000000000000000065312320602301013460 0ustar0000000000000000Dyre 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. dyre-0.8.12/Tests/recompile-relaunch/0000755000000000000000000000000012320602301015600 5ustar0000000000000000dyre-0.8.12/Tests/recompile-relaunch/runTest.sh0000755000000000000000000000131412320602301017602 0ustar0000000000000000#!/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() { echo "$1" >&2 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 dyre-0.8.12/Tests/recompile-relaunch/RecompileRelaunchTest.hs0000644000000000000000000000101112320602301022366 0ustar0000000000000000module 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 $ () } dyre-0.8.12/Tests/recompile-relaunch/Main.hs0000644000000000000000000000010612320602301017015 0ustar0000000000000000import RecompileRelaunchTest main = recompileRelaunchTest "Testing.." dyre-0.8.12/Tests/recompile-relaunch/recompileRelaunchTest.hs0000644000000000000000000000011112320602301022426 0ustar0000000000000000import RecompileRelaunchTest main = recompileRelaunchTest "..Successful" dyre-0.8.12/Tests/basic/0000755000000000000000000000000012320602301013103 5ustar0000000000000000dyre-0.8.12/Tests/basic/goodConfig.hs0000644000000000000000000000013112320602301015510 0ustar0000000000000000import BasicTest main = basicTest $ defaultConfig { message = "Basic Test Version 2.0" } dyre-0.8.12/Tests/basic/badConfig.hs0000644000000000000000000000013112320602301015306 0ustar0000000000000000import BasicTest main = basicTest $ defaultConfig { massage = "Basic Test Version 3.0" } dyre-0.8.12/Tests/basic/runTest.sh0000755000000000000000000000160712320602301015112 0ustar0000000000000000#!/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() { echo "$1" >&2 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 dyre-0.8.12/Tests/basic/BasicTest.hs0000644000000000000000000000146412320602301015325 0ustar0000000000000000module BasicTest where import qualified Config.Dyre as Dyre import Config.Dyre.Relaunch import Control.Monad 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 (Just err)) = putStrLn "Compile Error" realMain (Config message Nothing) = do state <- restoreTextState 1 when (state < 3) $ relaunchWithTextState (state + 1) Nothing putStrLn $ message ++ " - " ++ show state basicTest = Dyre.wrapMain $ Dyre.defaultParams { Dyre.projectName = "basicTest" , Dyre.realMain = realMain , Dyre.showError = showError , Dyre.statusOut = const . return $ () } dyre-0.8.12/Tests/basic/Main.hs0000644000000000000000000000006012320602301014317 0ustar0000000000000000import BasicTest main = basicTest defaultConfig dyre-0.8.12/Tests/config-check/0000755000000000000000000000000012320602301014342 5ustar0000000000000000dyre-0.8.12/Tests/config-check/ConfigCheckTest.hs0000644000000000000000000000103512320602301017700 0ustar0000000000000000module 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 } dyre-0.8.12/Tests/config-check/runTest.sh0000755000000000000000000000135412320602301016350 0ustar0000000000000000#!/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() { echo "$1" >&2 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 dyre-0.8.12/Tests/config-check/Main.hs0000644000000000000000000000006512320602301015563 0ustar0000000000000000import ConfigCheckTest main = configCheckMain "main" dyre-0.8.12/Tests/config-check/configCheckTestA.hs0000644000000000000000000000007112320602301020040 0ustar0000000000000000import ConfigCheckTest main = configCheckTest "custom-a" dyre-0.8.12/Tests/config-check/configCheckTestB.hs0000644000000000000000000000007112320602301020041 0ustar0000000000000000import ConfigCheckTest main = configCheckTest "custom-b" dyre-0.8.12/Config/0000755000000000000000000000000012320602301012125 5ustar0000000000000000dyre-0.8.12/Config/Dyre.hs0000644000000000000000000002406312320602301013371 0ustar0000000000000000{- | Dyre is a library for configuring your Haskell programs. Like Xmonad, programs configured with Dyre will look for a configuration file written in Haskell, which essentially defines a custom program configured exactly as the user wishes it to be. And since the configuration is written in Haskell, the user is free to do anything they might wish in the context of configuring the program. Dyre places emphasis on elegance of operation and ease of integration with existing applications. The 'wrapMain' function is the sole entry point for Dyre. When partially applied with a parameter structure, it wraps around the 'realMain' value from that structure, yielding an almost identical function which has been augmented with dynamic recompilation functionality. The 'Config.Dyre.Relaunch' module provides the ability to restart the program (recompiling if applicable), and persist state across restarts, but it has no impact whatsoever on the rest of the library whether it is used or not. 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 > } Notice that all of the program logic is contained in the 'DyreExample' module. The main module of the program is absolutely trivial, being essentially just the default configuration for the program: > -- Main.hs -- > import DyreExample > main = dyreExample defaultConfig The user can then create a custom configuration file, which overrides some or all of the default configuration: > -- ~/.config/dyreExample/dyreExample.hs -- > import DyreExample > main = dyreExample $ defaultConfig { message = "Dyre Example v0.1 (Modified)" } 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 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 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. 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. The above example can be tested by running Main.hs with 'runhaskell', and will detect custom configurations and recompile correctly even when the library isn't installed, so long as it is in the current directory when run. -} module Config.Dyre ( wrapMain, Params(..), defaultParams ) where import System.IO ( hPutStrLn, stderr ) import System.Directory ( doesFileExist, removeFile, canonicalizePath , getDirectoryContents, doesDirectoryExist ) import System.FilePath ( () ) import System.Environment (getArgs) import GHC.Environment (getFullArgs) import Control.Exception (assert) import Control.Monad ( when, filterM ) import Config.Dyre.Params ( Params(..), RTSOptionHandling(..) ) import Config.Dyre.Compile ( customCompile, getErrorPath, getErrorString ) import Config.Dyre.Compat ( customExec ) import Config.Dyre.Options ( getForceReconf, getDenyReconf, getDebug , withDyreOptions ) import Config.Dyre.Paths ( getPaths, maybeModTime ) -- | 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 , configCheck = True , configDir = Nothing , cacheDir = Nothing , realMain = undefined , showError = undefined , hidePackages = [] , ghcOpts = [] , forceRecomp = True , statusOut = hPutStrLn stderr , rtsOptsHandling = RTSAppend [] , includeCurrentDirectory = True } -- | 'wrapMain' is how Dyre recieves control of the program. It is expected -- that it will be partially applied with its parameters to yield a 'main' -- entry point, which will then be called by the 'main' function, as well -- as by any custom configurations. wrapMain :: Params cfgType -> cfgType -> IO () wrapMain params@Params{projectName = pName} cfg = withDyreOptions params $ -- Allow the 'configCheck' parameter to disable all of Dyre's recompilation -- checks, in favor of simply proceeding ahead to the 'realMain' function. if not $ configCheck params then realMain params cfg else do -- Get the important paths (thisBinary,tempBinary,configFile,cacheDir,libsDir) <- getPaths params libFiles <- recFiles libsDir libTimes <- mapM maybeModTime libFiles -- Check their modification times thisTime <- maybeModTime thisBinary tempTime <- maybeModTime tempBinary confTime <- maybeModTime configFile let confExists = confTime /= Nothing denyReconf <- getDenyReconf forceReconf <- getForceReconf -- Either the user or timestamps indicate we need to recompile let needReconf = or [ tempTime < confTime , tempTime < thisTime , or . map (tempTime <) $ libTimes , forceReconf ] -- If we're allowed to reconfigure, a configuration exists, and -- we detect a need to recompile it, then go ahead and compile. when (not denyReconf && confExists && needReconf) (customCompile params) -- 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 then do -- Canonicalize the paths for comparison to avoid symlinks -- throwing us off. We do it here instead of earlier because -- canonicalizePath throws an exception when the file is -- nonexistent. thisBinary' <- canonicalizePath thisBinary tempBinary' <- canonicalizePath tempBinary if thisBinary' /= tempBinary' then launchSub errorData tempBinary else enterMain errorData else enterMain errorData where launchSub errorData tempBinary = do statusOut params $ "Launching custom binary " ++ tempBinary ++ "\n" givenArgs <- handleRTSOptions $ rtsOptsHandling params -- Deny reconfiguration if a compile already failed. let arguments = case errorData of Nothing -> givenArgs Just _ -> "--deny-reconf":givenArgs -- 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 -- Enter the main program realMain params mainConfig recFiles :: FilePath -> IO [FilePath] recFiles d = do exists <- doesDirectoryExist d if exists then do nodes <- getDirectoryContents d let nodes' = map (d ) . filter (`notElem` [".", ".."]) $ nodes files <- filterM doesFileExist nodes' dirs <- filterM doesDirectoryExist nodes' subfiles <- concat `fmap` mapM recFiles dirs return $ files ++ subfiles else return [] assertM b = assert b $ return () -- | Filters GHC runtime system arguments: filterRTSArgs = filt False where filt _ [] = [] filt _ ("--RTS":rest) = [] filt False ("+RTS" :rest) = filt True rest filt True ("-RTS" :rest) = filt False rest filt False (_ :rest) = filt False rest filt True (arg :rest) = arg:filt True rest --filt state args = error $ "Error filtering RTS arguments in state " ++ show state ++ " remaining arguments: " ++ show args editRTSOptions opts (RTSReplace ls) = ls editRTSOptions opts (RTSAppend ls) = opts ++ ls handleRTSOptions h = do fargs <- getFullArgs args <- getArgs let rtsArgs = editRTSOptions (filterRTSArgs fargs) h assertM $ not $ "--RTS" `elem` rtsArgs case rtsArgs of [] -> if not $ "+RTS" `elem` args then return args -- cleaner output else return $ "--RTS":args _ -> return $ ["+RTS"] ++ rtsArgs ++ ["--RTS"] ++ args dyre-0.8.12/Config/Dyre/0000755000000000000000000000000012320602301013030 5ustar0000000000000000dyre-0.8.12/Config/Dyre/Relaunch.hs0000644000000000000000000001106412320602301015127 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {- This is the only other module aside from 'Config.Dyre' which needs to be imported specially. It contains functions for restarting the program (which, usefully, will cause a recompile if the config has been changed), as well as saving and restoring state across said restarts. The impossibly simple function arguments are a consequence of a little cheating we do using the 'System.IO.Storage' library. Of course, we can't use the stored data unless something else put it there, so this module will probably explode horribly if used outside of a program whose recompilation is managed by Dyre. The functions for saving and loading state come in two variants: one which uses the 'Read' and 'Show' typeclasses, and one which uses Data.Binary to serialize it. The 'Read' and 'Show' versions are much easier to use thanks to automatic deriving, but the binary versions offer more control over saving and loading, as well as probably being a bit faster. -} module Config.Dyre.Relaunch ( relaunchMaster , relaunchWithTextState , relaunchWithBinaryState , saveTextState , saveBinaryState , restoreTextState , restoreBinaryState ) where import Data.Maybe ( fromMaybe, fromJust ) import System.IO ( writeFile, readFile ) import Data.Binary ( Binary, encodeFile, decodeFile ) import Control.Exception ( try, SomeException ) import System.FilePath ( () ) import System.Directory ( getTemporaryDirectory, removeFile ) import System.IO.Storage ( putValue, delValue ) import Config.Dyre.Options ( customOptions, getMasterBinary, getStatePersist ) import Config.Dyre.Compat ( customExec, getPIDString ) -- | Just relaunch the master binary. We don't have any important -- state to worry about. (Or, like when 'relaunchWithState' calls -- it, we're managing state on our own). It takes an argument which -- can optionally specify a new set of arguments. If it is given a -- value of 'Nothing', the current value of 'getArgs' will be used. relaunchMaster :: Maybe [String] -> IO () relaunchMaster otherArgs = do masterPath <- fmap fromJust getMasterBinary customExec masterPath otherArgs -- | Relaunch the master binary, but first preserve the program -- state so that we can use the 'restoreTextState' functions to -- get it back again later. relaunchWithTextState :: Show a => a -> Maybe [String] -> IO () relaunchWithTextState state otherArgs = do saveTextState state relaunchMaster otherArgs -- | Serialize the state for later restoration with 'restoreBinaryState', -- and then relaunch the master binary. relaunchWithBinaryState :: Binary a => a -> Maybe [String] -> IO () relaunchWithBinaryState state otherArgs = do saveBinaryState state relaunchMaster otherArgs -- | Calculate the path that will be used for saving the state. -- The path used to load the state, meanwhile, is passed to the -- program with the '--dyre-persist-state=' flag. genStatePath :: IO FilePath genStatePath = do pidString <- getPIDString tempDir <- getTemporaryDirectory let statePath = tempDir pidString ++ ".state" putValue "dyre" "persistState" statePath return statePath -- | Serialize a state as text, for later loading with the -- 'restoreTextState' function. saveTextState :: Show a => a -> IO () saveTextState state = do statePath <- genStatePath writeFile statePath . show $ state -- | Serialize a state as binary data, for later loading with -- the 'restoreBinaryState' function. saveBinaryState :: Binary a => a -> IO () saveBinaryState state = do statePath <- genStatePath encodeFile statePath . Just $ state -- | Restore state which has been serialized through the -- 'saveTextState' function. Takes a default which is -- returned if the state doesn't exist. restoreTextState :: Read a => a -> IO a restoreTextState d = do statePath <- getStatePersist case statePath of Nothing -> return d Just sp -> do stateData <- readFile sp result <- try $ readIO stateData case result of Left (_ :: SomeException) -> return d Right v -> return v -- | Restore state which has been serialized through the -- 'saveBinaryState' function. Takes a default which is -- returned if the state doesn't exist. restoreBinaryState :: Binary a => a -> IO a restoreBinaryState d = do statePath <- getStatePersist case statePath of Nothing -> return d Just sp -> do state <- decodeFile sp return $ fromMaybe d state dyre-0.8.12/Config/Dyre/Compile.hs0000644000000000000000000000623412320602301014761 0ustar0000000000000000{- | 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, getErrorPath, getErrorString ) where import System.IO ( openFile, hClose, IOMode(..) ) import System.Exit ( ExitCode(..) ) import System.Process ( runProcess, waitForProcess ) import System.FilePath ( () ) import System.Directory ( getCurrentDirectory, doesFileExist , createDirectoryIfMissing ) import Control.Exception ( bracket ) import GHC.Paths ( ghc ) 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 () customCompile params@Params{statusOut = output} = do (thisBinary, tempBinary, configFile, cacheDir, libsDir) <- getPaths params output $ "Configuration '" ++ configFile ++ "' changed. Recompiling." createDirectoryIfMissing True cacheDir -- Compile occurs in here errFile <- getErrorPath params result <- bracket (openFile errFile WriteMode) hClose $ \errHandle -> do ghcOpts <- makeFlags params configFile tempBinary cacheDir libsDir ghcProc <- runProcess ghc ghcOpts (Just cacheDir) Nothing Nothing Nothing (Just errHandle) waitForProcess ghcProc -- Display a helpful little status message if result /= ExitSuccess then output "Error occurred while loading configuration file." else output "Program reconfiguration successful." -- | Assemble the arguments to GHC so everything compiles right. makeFlags :: Params cfgType -> FilePath -> FilePath -> FilePath -> FilePath -> IO [String] makeFlags Params{ghcOpts = flags, hidePackages = hides, forceRecomp = force, includeCurrentDirectory = includeCurDir} cfgFile tmpFile cacheDir libsDir = do currentDir <- getCurrentDirectory return . concat $ [ ["-v0", "-i" ++ libsDir] , if includeCurDir then ["-i" ++ currentDir] else [] , ["-outputdir", cacheDir] , prefix "-hide-package" hides, flags , ["--make", cfgFile, "-o", tmpFile] , ["-fforce-recomp" | force] -- Only if force is true ] where prefix y = concatMap $ \x -> [y,x] dyre-0.8.12/Config/Dyre/Options.hs0000644000000000000000000001327112320602301015023 0ustar0000000000000000{- Handling for the command-line options that can be used to configure Dyre. As of the last count, there are four of them, and more are unlikely to be needed. The only one that a user should ever need to use is the '--force-reconf' option, so the others all begin with '--dyre-'. At the start of the program, before anything else occurs, the 'withDyreOptions' function is used to hide Dyre's command-line options. They are loaded into the IO monad using the module 'System.IO.Storage'. This keeps them safely out of the way of the user code and our own. Later, when Dyre needs to access the options, it does so through the accessor functions defined here. When it comes time to pass control over to a new binary, it gets an argument list which preserves the important flags with a call to 'customOptions'. -} module Config.Dyre.Options ( removeDyreOptions , withDyreOptions , customOptions , getDenyReconf , getForceReconf , getDebug , getMasterBinary , getStatePersist ) where import Data.List (isPrefixOf) import Data.Maybe (fromJust) import System.IO.Storage (withStore, putValue, getValue, getDefaultValue) import System.Environment (getArgs, getProgName, withArgs) import System.Environment.Executable (getExecutablePath) import Config.Dyre.Params -- | Remove all Dyre's options from the given commandline arguments. removeDyreOptions :: [String] -> [String] removeDyreOptions = filter $ not . prefixElem dyreArgs where prefixElem xs = or . zipWith ($) (map isPrefixOf xs) . repeat -- | Store Dyre's command-line options to the IO-Store "dyre", -- and then execute the provided IO action with all Dyre's -- options removed from the command-line arguments. withDyreOptions :: Params c -> IO a -> IO a withDyreOptions Params{configCheck = check} action = withStore "dyre" $ do -- Pretty important args <- getArgs -- If the flag exists, it overrides the current file. Likewise, -- if it doesn't exist, we end up with the path to our current -- file. This seems like a sensible way to do it. -- Don't use 'getExecutablePath' if we're byassing the rest of Dyre. this <- if check then getExecutablePath else getProgName putValue "dyre" "masterBinary" this storeFlag args "--dyre-master-binary=" "masterBinary" -- 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' withArgs (removeDyreOptions args) action -- | Get the value of the '--force-reconf' flag, which is used -- to force a recompile of the custom configuration. 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 -- directory, and './' as the configuration directory. getDebug :: IO Bool getDebug = getDefaultValue "dyre" "debugMode" False -- | Get the path to the master binary. This is set to the path of -- the *current* binary unless the '--dyre-master-binary=' flag -- is set. Obviously, we pass the '--dyre-master-binary=' flag to -- the custom configured application from the master binary. getMasterBinary :: IO (Maybe String) getMasterBinary = getValue "dyre" "masterBinary" -- | Get the path to a persistent state file. This is set only when -- the '--dyre-state-persist=' flag is passed to the program. It -- is used internally by 'Config.Dyre.Relaunch' to save and restore -- state when relaunching the program. getStatePersist :: IO (Maybe String) getStatePersist = getValue "dyre" "persistState" -- | Return the set of options which will be passed to another instance -- of Dyre. Preserves the master binary, state file, and debug mode -- flags, but doesn't pass along the forced-recompile flag. Can be -- passed a set of other arguments to use, or it defaults to using -- the current arguments when passed 'Nothing'. customOptions :: Maybe [String] -> IO [String] customOptions otherArgs = do masterPath <- getMasterBinary stateFile <- getStatePersist debugMode <- getDebug mainArgs <- case otherArgs of Nothing -> getArgs Just oa -> return oa -- Combine the other arguments with the Dyre-specific ones let args = mainArgs ++ (filter (not . null) $ [ if debugMode then "--dyre-debug" else "" , case stateFile of Nothing -> "" Just sf -> "--dyre-state-persist=" ++ sf , "--dyre-master-binary=" ++ fromJust masterPath ]) return args -- | Look for the given flag in the argument array, and store -- its value under the given name if it exists. storeFlag :: [String] -> String -> String -> IO () storeFlag args flag name | null match = return () | otherwise = putValue "dyre" name $ drop (length flag) (head match) where match = filter (isPrefixOf flag) args -- | The array of all arguments that Dyre recognizes. Used to -- make sure none of them are visible past 'withDyreOptions' dyreArgs :: [String] dyreArgs = [ "--force-reconf", "--deny-reconf" , "--dyre-state-persist", "--dyre-debug" , "--dyre-master-binary" ] dyre-0.8.12/Config/Dyre/Params.hs0000644000000000000000000000531312320602301014611 0ustar0000000000000000{- | Defines the 'Params' datatype which Dyre uses to define all program-specific configuration data. Shouldn't be imported directly, as 'Config.Dyre' re-exports it. -} module Config.Dyre.Params ( Params(..), RTSOptionHandling(..) ) where -- | This structure is how all kinds of useful data is fed into Dyre. Of -- course, only the 'projectName', 'realMain', and 'showError' fields -- are really necessary. By using the set of default values provided -- as 'Config.Dyre.defaultParams', you can get all the benefits of -- using Dyre to configure your program in only five or six lines of -- code. data Params cfgType = Params { projectName :: String -- ^ The name of the project. This needs to also be the name of -- the executable, and the name of the configuration file. , configCheck :: Bool -- ^ Should Dyre look for and attempt to compile custom configurations? -- Useful for creating program entry points that bypass Dyre's -- recompilation, for testing purposes. , configDir :: Maybe (IO FilePath) -- ^ The directory to look for a configuration file in. , cacheDir :: Maybe (IO FilePath) -- ^ The directory to store build files in, including the final -- generated executable. , realMain :: cfgType -> IO () -- ^ The main function of the program. When Dyre has completed -- all of its recompilation, it passes the configuration data -- to this function and gets out of the way. , showError :: cfgType -> String -> cfgType -- ^ This function is used to display error messages that occur -- during recompilation, by allowing the program to modify its -- initial configuration. , hidePackages :: [String] -- ^ Packages that need to be hidden during compilation , ghcOpts :: [String] -- ^ Miscellaneous GHC compilation settings go here , forceRecomp :: Bool -- ^ Should GHC be given the -fforce-recomp flag? , statusOut :: String -> IO () -- ^ A status output function. Will be called with messages -- when Dyre recompiles or launches anything. A good value -- is 'hPutStrLn stderr', assuming there is no pressing -- reason to not put messages on stderr. , rtsOptsHandling :: RTSOptionHandling -- ^ Whether to append, or replace GHC runtime system options -- with others. , includeCurrentDirectory :: Bool -- ^ Whether to add current directory to include list (set False to -- prevent name shadowing within project directory.) -- } data RTSOptionHandling = RTSReplace [String] -- replaces RTS options with given list | RTSAppend [String] -- merges given list with RTS options from command line (so that nothing is lost) dyre-0.8.12/Config/Dyre/Compat.hs0000644000000000000000000000605612320602301014616 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ForeignFunctionInterface #-} {- | Compatibility code for things that need to be done differently on different systems. -} module Config.Dyre.Compat ( customExec, getPIDString ) where import Config.Dyre.Options ( customOptions ) #if defined(mingw32_HOST_OS) || defined(__MINGW32__) -- Windows import System.Win32 import System.Process import System.Exit import System.Mem -- This can be removed as soon as a 'getProcessID' function -- gets added to 'System.Win32' foreign import stdcall unsafe "winbase.h GetCurrentProcessId" c_GetCurrentProcessID :: IO DWORD getPIDString = fmap show c_GetCurrentProcessID customExec binary mArgs = do args <- customOptions mArgs -- This whole thing is a terrible, ugly hack. Since Windows -- is too braindead to provide an exec() system call for us -- to use, we simply create a new process that inherits -- the stdio handles. (_,_,_,child) <- createProcess $ CreateProcess { cmdspec = RawCommand binary args , cwd = Nothing , env = Nothing , std_in = Inherit , std_out = Inherit , std_err = Inherit , close_fds = True , create_group = False } -- Do some garbage collection in an optimistic attempt to -- offset some of the memory we waste here. performGC -- And to prevent terminal apps from losing IO, we have to -- sit around waiting for the child to exit. exitCode <- waitForProcess child case exitCode of ExitSuccess -> c_ExitProcess 0 ExitFailure c -> c_ExitProcess (fromIntegral c) foreign import stdcall unsafe "winbase.h ExitProcess" c_ExitProcess :: UINT -> IO () #else import System.Posix.Process ( executeFile, getProcessID, exitImmediately , forkProcess, getProcessStatus, ProcessStatus(..) ) import System.Posix.Signals ( raiseSignal, sigTSTP ) import System.Exit ( ExitCode(..) ) getPIDString = fmap show getProcessID #ifdef darwin_HOST_OS -- OSX customExec binary mArgs = do args <- customOptions mArgs childPID <- forkProcess $ executeFile binary False args Nothing forever $ do childStatus <- getProcessStatus True True childPID case childStatus of Nothing -> error "executeFile: couldn't get child process status" Just (Exited code) -> exitImmediately code #if MIN_VERSION_unix(2,7,0) Just (Terminated _ _) -> exitImmediately ExitSuccess #else Just (Terminated _) -> exitImmediately ExitSuccess #endif Just (Stopped _) -> raiseSignal sigTSTP where forever a = a >> forever a #else -- Linux / BSD customExec binary mArgs = do args <- customOptions mArgs executeFile binary False args Nothing #endif #endif -- | Called whenever execution needs to be transferred over to -- a different binary. customExec :: FilePath -> Maybe [String] -> IO () -- | What it says on the tin. Gets the current PID as a string. -- Used to determine the name for the state file during restarts. getPIDString :: IO String dyre-0.8.12/Config/Dyre/Paths.hs0000644000000000000000000000361012320602301014443 0ustar0000000000000000module Config.Dyre.Paths where import System.Info (os, arch) import System.FilePath ( (), (<.>), takeExtension ) import System.Directory (getCurrentDirectory, doesFileExist, getModificationTime) import System.Environment.XDG.BaseDir (getUserCacheDir, getUserConfigDir) import System.Environment.Executable (getExecutablePath) import Data.Time import Config.Dyre.Params import Config.Dyre.Options -- | Return the paths to, respectively, the current binary, the custom -- binary, the config file, and the cache directory. getPaths :: Params c -> IO (FilePath, FilePath, FilePath, FilePath, FilePath) getPaths params@Params{projectName = pName} = do thisBinary <- getExecutablePath debugMode <- getDebug cwd <- getCurrentDirectory cacheDir <- case (debugMode, cacheDir params) of (True, _ ) -> return $ cwd "cache" (False, Nothing) -> getUserCacheDir pName (False, Just cd) -> cd configDir <- case (debugMode, configDir params) of (True, _ ) -> return cwd (False, Nothing) -> getUserConfigDir pName (False, Just cd) -> cd let tempBinary = cacheDir pName ++ "-" ++ os ++ "-" ++ arch <.> takeExtension thisBinary let configFile = configDir pName ++ ".hs" let libsDir = configDir "lib" return (thisBinary, tempBinary, configFile, cacheDir, libsDir) -- | Check if a file exists. If it exists, return Just the modification -- time. If it doesn't exist, return Nothing. maybeModTime path = do fileExists <- doesFileExist path if fileExists then fmap Just $ getModificationTime path else return Nothing -- Removed type signature because it can't satisfy GHC 7.4 and 7.6 at once -- maybeModTime :: FilePath -> IO (Maybe UTCTime)