diff --git a/CHANGES.txt b/CHANGES.txt
new file mode 100644
--- /dev/null
+++ b/CHANGES.txt
@@ -0,0 +1,4 @@
+Changelog for Rattle (* = breaking change)
+
+0.1, released 2019-04-17
+ Initial version, not ready for public use
diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,217 @@
+Copyright Neil Mitchell 2019.
+
+Licensed under either of:
+
+* BSD-3-Clause license (https://opensource.org/licenses/BSD-3-Clause)
+* Apache License, version 2.0 (https://opensource.org/licenses/Apache-2.0)
+
+As a user, you may use this code under either license, at your option.
+
+
+---------------------------------------------------------------------
+BSD 3-Clause License
+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 Neil Mitchell nor the names of other
+ 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
+OWNER 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.
+
+
+---------------------------------------------------------------------
+Apache License
+Version 2.0, January 2004
+
+
+Terms and Conditions for use, reproduction, and distribution
+1. Definitions
+"License" shall mean the terms and conditions for use, reproduction,
+and distribution as defined by Sections 1 through 9 of this document.
+
+"Licensor" shall mean the copyright owner or entity authorized by the
+copyright owner that is granting the License.
+
+"Legal Entity" shall mean the union of the acting entity and all
+other entities that control, are controlled by, or are under common
+control with that entity. For the purposes of this definition,
+"control" means (i) the power, direct or indirect, to cause the
+direction or management of such entity, whether by contract or
+otherwise, or (ii) ownership of fifty percent (50%) or more of the
+outstanding shares, or (iii) beneficial ownership of such entity.
+
+"You" (or "Your") shall mean an individual or Legal Entity exercising
+permissions granted by this License.
+
+"Source" form shall mean the preferred form for making modifications,
+including but not limited to software source code, documentation
+source, and configuration files.
+
+"Object" form shall mean any form resulting from mechanical
+transformation or translation of a Source form, including but not
+limited to compiled object code, generated documentation, and
+conversions to other media types.
+
+"Work" shall mean the work of authorship, whether in Source or Object
+form, made available under the License, as indicated by a copyright
+notice that is included in or attached to the work).
+
+"Derivative Works" shall mean any work, whether in Source or Object
+form, that is based on (or derived from) the Work and for which the
+editorial revisions, annotations, elaborations, or other
+modifications represent, as a whole, an original work of authorship.
+For the purposes of this License, Derivative Works shall not include
+works that remain separable from, or merely link (or bind by name) to
+the interfaces of, the Work and Derivative Works thereof.
+
+"Contribution" shall mean any work of authorship, including the
+original version of the Work and any modifications or additions to
+that Work or Derivative Works thereof, that is intentionally
+submitted to Licensor for inclusion in the Work by the copyright
+owner or by an individual or Legal Entity authorized to submit on
+behalf of the copyright owner. For the purposes of this definition,
+"submitted" means any form of electronic, verbal, or written
+communication sent to the Licensor or its representatives, including
+but not limited to communication on electronic mailing lists, source
+code control systems, and issue tracking systems that are managed by,
+or on behalf of, the Licensor for the purpose of discussing and
+improving the Work, but excluding communication that is conspicuously
+marked or otherwise designated in writing by the copyright owner as
+"Not a Contribution."
+
+"Contributor" shall mean Licensor and any individual or Legal Entity
+on behalf of whom a Contribution has been received by Licensor and
+subsequently incorporated within the Work.
+
+2. Grant of Copyright License
+Subject to the terms and conditions of this License, each Contributor
+hereby grants to You a perpetual, worldwide, non-exclusive,
+no-charge, royalty-free, irrevocable copyright license to reproduce,
+prepare Derivative Works of, publicly display, publicly perform,
+sublicense, and distribute the Work and such Derivative Works in
+Source or Object form.
+
+3. Grant of Patent License
+Subject to the terms and conditions of this License, each Contributor
+hereby grants to You a perpetual, worldwide, non-exclusive,
+no-charge, royalty-free, irrevocable (except as stated in this
+section) patent license to make, have made, use, offer to sell, sell,
+import, and otherwise transfer the Work, where such license applies
+only to those patent claims licensable by such Contributor that are
+necessarily infringed by their Contribution(s) alone or by
+combination of their Contribution(s) with the Work to which such
+Contribution(s) was submitted. If You institute patent litigation
+against any entity (including a cross-claim or counterclaim in a
+lawsuit) alleging that the Work or a Contribution incorporated within
+the Work constitutes direct or contributory patent infringement, then
+any patent licenses granted to You under this License for that Work
+shall terminate as of the date such litigation is filed.
+
+4. Redistribution
+You may reproduce and distribute copies of the Work or Derivative
+Works thereof in any medium, with or without modifications, and in
+Source or Object form, provided that You meet the following
+conditions:
+
+(a) You must give any other recipients of the Work or Derivative
+Works a copy of this License; and
+(b) You must cause any modified files to carry prominent notices
+stating that You changed the files; and
+(c) You must retain, in the Source form of any Derivative Works that
+You distribute, all copyright, patent, trademark, and attribution
+notices from the Source form of the Work, excluding those notices
+that do not pertain to any part of the Derivative Works; and
+(d) If the Work includes a "NOTICE" text file as part of its
+distribution, then any Derivative Works that You distribute must
+include a readable copy of the attribution notices contained within
+such NOTICE file, excluding those notices that do not pertain to any
+part of the Derivative Works, in at least one of the following
+places: within a NOTICE text file distributed as part of the
+Derivative Works; within the Source form or documentation, if
+provided along with the Derivative Works; or, within a display
+generated by the Derivative Works, if and wherever such third-party
+notices normally appear. The contents of the NOTICE file are for
+informational purposes only and do not modify the License. You may
+add Your own attribution notices within Derivative Works that You
+distribute, alongside or as an addendum to the NOTICE text from the
+Work, provided that such additional attribution notices cannot be
+construed as modifying the License.
+You may add Your own copyright statement to Your modifications and
+may provide additional or different license terms and conditions for
+use, reproduction, or distribution of Your modifications, or for any
+such Derivative Works as a whole, provided Your use, reproduction,
+and distribution of the Work otherwise complies with the conditions
+stated in this License.
+
+5. Submission of Contributions
+Unless You explicitly state otherwise, any Contribution intentionally
+submitted for inclusion in the Work by You to the Licensor shall be
+under the terms and conditions of this License, without any
+additional terms or conditions. Notwithstanding the above, nothing
+herein shall supersede or modify the terms of any separate license
+agreement you may have executed with Licensor regarding such
+Contributions.
+
+6. Trademarks
+This License does not grant permission to use the trade names,
+trademarks, service marks, or product names of the Licensor, except
+as required for reasonable and customary use in describing the origin
+of the Work and reproducing the content of the NOTICE file.
+
+7. Disclaimer of Warranty
+Unless required by applicable law or agreed to in writing, Licensor
+provides the Work (and each Contributor provides its Contributions)
+on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND,
+either express or implied, including, without limitation, any
+warranties or conditions of TITLE, NON-INFRINGEMENT, MERCHANTABILITY,
+or FITNESS FOR A PARTICULAR PURPOSE. You are solely responsible for
+determining the appropriateness of using or redistributing the Work
+and assume any risks associated with Your exercise of permissions
+under this License.
+
+8. Limitation of Liability
+In no event and under no legal theory, whether in tort (including
+negligence), contract, or otherwise, unless required by applicable
+law (such as deliberate and grossly negligent acts) or agreed to in
+writing, shall any Contributor be liable to You for damages,
+including any direct, indirect, special, incidental, or consequential
+damages of any character arising as a result of this License or out
+of the use or inability to use the Work (including but not limited to
+damages for loss of goodwill, work stoppage, computer failure or
+malfunction, or any and all other commercial damages or losses), even
+if such Contributor has been advised of the possibility of such
+damages.
+
+9. Accepting Warranty or Additional Liability
+While redistributing the Work or Derivative Works thereof, You may
+choose to offer, and charge a fee for, acceptance of support,
+warranty, indemnity, or other liability obligations and/or rights
+consistent with this License. However, in accepting such obligations,
+You may act only on Your own behalf and on Your sole responsibility,
+not on behalf of any other Contributor, and only if You agree to
+indemnify, defend, and hold each Contributor harmless for any
+liability incurred by, or claims asserted against, such Contributor
+by reason of your accepting any such warranty or additional
+liability.
diff --git a/README.md b/README.md
new file mode 100644
--- /dev/null
+++ b/README.md
@@ -0,0 +1,28 @@
+# Rattle [](https://hackage.haskell.org/package/rattle) [](https://www.stackage.org/package/rattle) [](https://travis-ci.org/ndmitchell/rattle) [](https://ci.appveyor.com/project/ndmitchell/rattle)
+
+A very early prototype of a unique build system.
+
+A forward based build system, where you can make calls to `cmd`. These are:
+
+1) Skipped if their inputs/outputs haven't changed
+2) Have their outputs copied in if only the outputs have changed
+3) Can be speculated in advance
+
+The innovation over something like Fabricate is that I have a notion
+of hazards - if two rules write to the same file, or one writes after
+another reads, I consider that a build hazard and throw an error - the
+result is no longer consistent. For speculation, I just run commands
+that look useful and don't look like they'll cause a hazard. If
+speculation does cause a hazard, I give up and try again without
+speculation.
+
+This build system fundamentally relies on tracing the files used by system commands, and currently uses the [`fsatrace`](https://github.com/jacereda/fsatrace) program to do so, which must be installed. As a consequence of the design, if `fsatrace` fails, then `rattle` won't work properly. Example reasons that `fsatrace` might fail include:
+
+* If you use Go compiled binaries on Linux or Mac then it's unlikely to be traced, see [Issue 24](https://github.com/jacereda/fsatrace/issues/24).
+* If you a Mac OS X 1.10 or higher then system binaries that themselves invoke system binaries they won't be traced, unless you [disable System Integrity Protection](https://developer.apple.com/library/content/documentation/Security/Conceptual/System_Integrity_Protection_Guide/ConfiguringSystemIntegrityProtection/ConfiguringSystemIntegrityProtection.html) (which you do at your own risk).
+* If you use statically linked binaries on Linux they probably won't be traced.
+
+It is possible to write alternative tracing mechanisms that wouldn't have these limitations, for example:
+
+* [Bigbro](https://github.com/droundy/bigbro/) uses `ptrace` so works for Go binaries and statically linked binaries.
+* [traced-fs](https://github.com/jacereda/traced-fs) is an unfinished file system tracer that implements a user file system that would also work for Go binaries and static linking.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/rattle.cabal b/rattle.cabal
new file mode 100644
--- /dev/null
+++ b/rattle.cabal
@@ -0,0 +1,72 @@
+cabal-version: >= 1.18
+build-type: Simple
+name: rattle
+version: 0.1
+license: BSD3
+x-license: BSD-3-Clause OR Apache-2.0
+license-file: LICENSE
+category: Development
+author: Neil Mitchell
+maintainer: Neil Mitchell
+copyright: Neil Mitchell 2019
+synopsis: Forward build system, with caching and speculation
+description:
+ A forward build system like Fabrciate but with speculation and remote caching.
+homepage: https://github.com/ndmitchell/rattle#readme
+bug-reports: https://github.com/ndmitchell/rattle/issues
+tested-with: GHC==8.6.4, GHC==8.4.4, GHC==8.2.2
+extra-doc-files:
+ CHANGES.txt
+ README.md
+extra-source-files:
+ test/C/constants.c
+ test/C/constants.h
+ test/C/main.c
+
+source-repository head
+ type: git
+ location: https://github.com/ndmitchell/rattle.git
+
+library
+ default-language: Haskell2010
+ hs-source-dirs: src
+ build-depends:
+ base >= 4.8 && < 5,
+ bytestring,
+ cryptohash-sha256,
+ deepseq >= 1.1,
+ directory,
+ extra >= 1.6.14,
+ filepath,
+ hashable >= 1.1.2.3,
+ shake >= 0.17.8,
+ time,
+ transformers >= 0.2,
+ unordered-containers >= 0.2.7
+
+ exposed-modules:
+ Development.Rattle
+
+ other-modules:
+ Development.Rattle.Hash
+ Development.Rattle.Limit
+ Development.Rattle.Server
+ Development.Rattle.Shared
+ Development.Rattle.Types
+ General.Bilist
+ General.Extra
+ General.Thread
+
+test-suite rattle-test
+ default-language: Haskell2010
+ type: exitcode-stdio-1.0
+ main-is: test/Test.hs
+ ghc-options: -main-is Test.main -rtsopts -with-rtsopts=-K1K -threaded
+
+ build-depends:
+ base >= 4.8 && < 5,
+ directory,
+ extra,
+ filepattern,
+ rattle,
+ shake
diff --git a/src/Development/Rattle.hs b/src/Development/Rattle.hs
new file mode 100644
--- /dev/null
+++ b/src/Development/Rattle.hs
@@ -0,0 +1,48 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+-- | General rules for writing consistent rattle build systems:
+--
+-- * Never write to the same file twice. Never read then write.
+--
+-- * Don't delete files that have been produced. Each command should make
+-- new files, not delete old files.
+module Development.Rattle(
+ rattle, Run,
+ Hazard,
+ RattleOptions(..), rattleOptions,
+ cmd,
+ parallel, forP,
+ liftIO
+ ) where
+
+import Control.Monad.Trans.Reader
+import Control.Monad.IO.Class
+import Development.Rattle.Server
+import General.Thread
+
+
+-- | Type of actions to run. Executed using 'rattle'.
+newtype Run a = Run {fromRun :: ReaderT Rattle IO a}
+ deriving (Functor, Applicative, Monad, MonadIO)
+
+-- | Run a sequence of 'Run' actions in parallel. They will be run in parallel with no limit
+-- on simultaneous executions.
+parallel :: [Run a] -> Run [a]
+parallel xs = do
+ r <- Run ask
+ liftIO $ withThreadsList $ map (flip runReaderT r . fromRun) xs
+
+-- | Parallel version of 'forM'.
+forP :: (a -> Run b) -> [a] -> Run [b]
+forP f xs = parallel $ map f xs
+
+-- | Run a system command with the given arguments.
+cmd :: [String] -> Run ()
+cmd args = do
+ r <- Run ask
+ liftIO $ cmdRattle r args
+
+-- | Given an Action to run, and a list of previous commands that got run, run it again
+rattle :: RattleOptions -> Run a -> IO a
+rattle opts (Run act) = withRattle opts $ \r ->
+ runReaderT act r
diff --git a/src/Development/Rattle/Hash.hs b/src/Development/Rattle/Hash.hs
new file mode 100644
--- /dev/null
+++ b/src/Development/Rattle/Hash.hs
@@ -0,0 +1,72 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module Development.Rattle.Hash(
+ Hash, fromHash,
+ hashFile, hashString
+ ) where
+
+import System.IO
+import Data.Hashable
+import qualified Crypto.Hash.SHA256 as SHA
+import qualified Data.ByteString.Char8 as BS
+import qualified Data.ByteString.Lazy.Char8 as LBS
+import qualified Data.HashMap.Strict as Map
+import Data.Time
+import System.Directory
+import Data.Char
+import System.IO.Unsafe
+import System.IO.Error
+import Control.Monad.Extra
+import Data.IORef
+import Numeric
+import Control.Exception.Extra
+import Control.DeepSeq
+
+
+newtype Hash = Hash String
+ deriving (NFData, Show, Read, Eq, Hashable)
+
+fromHash :: Hash -> String
+fromHash (Hash x) = x
+
+
+mkHash :: BS.ByteString -> Hash
+mkHash = Hash . concatMap (f . ord) . BS.unpack
+ where f i = ['0' | i < 16] ++ showHex i ""
+
+
+-- Hashing lots of files is expensive, so we keep a cache
+{-# NOINLINE hashCache #-}
+hashCache :: IORef (Map.HashMap FilePath (UTCTime, Hash))
+hashCache = unsafePerformIO $ newIORef Map.empty
+
+
+getModTime :: FilePath -> IO (Maybe UTCTime)
+getModTime x = handleBool isDoesNotExistError (const $ return Nothing) (Just <$> getModificationTime x)
+
+
+hashFile :: FilePath -> IO (Maybe Hash)
+hashFile file = do
+ start <- getModTime file
+ case start of
+ Nothing -> return Nothing
+ Just start -> do
+ mp <- readIORef hashCache
+ case Map.lookup file mp of
+ Just (time, hash) | time == start -> return $ Just hash
+ _ -> do
+ -- we can get a ModTime on a directory, but can't withFile it
+ b <- doesFileExist file
+ if not b then return Nothing else do
+ res <- withFile file ReadMode $ \h -> do
+ chunks <- LBS.hGetContents h
+ evaluate $ force $ mkHash $ SHA.finalize $ SHA.updates SHA.init $ LBS.toChunks chunks
+ end <- getModTime file
+ when (Just start == end) $
+ atomicModifyIORef' hashCache $ \mp -> (Map.insert file (start, res) mp, ())
+ return $ Just res
+
+
+hashString :: String -> Hash
+-- we first 'show' the String to avoid having > 256 characters in it
+hashString = mkHash . SHA.hash . BS.pack . show
diff --git a/src/Development/Rattle/Limit.hs b/src/Development/Rattle/Limit.hs
new file mode 100644
--- /dev/null
+++ b/src/Development/Rattle/Limit.hs
@@ -0,0 +1,72 @@
+{-# LANGUAGE TupleSections, LambdaCase #-}
+
+module Development.Rattle.Limit(
+ Limit, newLimit, withLimit, withLimitMaybe,
+ ) where
+
+import qualified General.Bilist as B
+import Control.Exception
+import Control.Monad
+import Control.Concurrent.Extra
+
+
+newtype Limit = Limit (Var S)
+
+data S = Free !Int
+ | Queued (B.Bilist (IO ()))
+
+
+newLimit :: Int -> IO Limit
+newLimit i
+ | i < 1 = error $ "newLimit, argument must be >= 1, got " ++ show i
+ | otherwise = Limit <$> newVar (Free i)
+
+data LS
+ = Wait -- I am waiting like normal, default state
+ | Fire -- I got asked to run
+ | Died -- I got an async exception
+
+withLimit :: Limit -> IO a -> IO a
+withLimit (Limit var) act = mask $ \unmask ->
+ join $ modifyVar var $ \x -> case x of
+ Free i | i >= 1 -> return $ (Free (i-1),) $
+ execute unmask
+ _ -> do
+ let q = case x of Queued q -> q; _ -> mempty
+ -- a real pain to deal with async exceptions while waiting
+ -- but I think this does it - although not very elegant
+ wait <- newBarrier
+ ls <- newVar Wait
+ let go = join $ modifyVar ls $ \x -> return $ case x of
+ Wait -> (Fire, signalBarrier wait ())
+ Died -> (Died, finished var)
+ return $ (Queued $ B.cons go q, ) $ do
+ unmask (waitBarrier wait) `onException` do
+ join $ modifyVar ls $ \x -> return $ case x of
+ Wait -> (Died, return ())
+ Fire -> (Fire, finished var)
+ execute unmask
+ where
+ execute unmask = do
+ res <- unmask act `onException` finished var
+ finished var
+ return res
+
+
+withLimitMaybe :: Limit -> IO a -> IO (Maybe a)
+withLimitMaybe (Limit var) act = mask $ \unmask ->
+ join $ modifyVar var $ \x -> case x of
+ Free i | i >= 1 -> return $ (Free (i-1),) $ do
+ res <- unmask act `onException` finished var
+ finished var
+ return $ Just res
+ _ -> return (x, return Nothing)
+
+
+finished :: Var S -> IO ()
+finished var = mask_ $
+ join $ modifyVar var $ \case
+ Free i -> return (Free (i+1), return ())
+ Queued q -> case B.uncons q of
+ Nothing -> return (Free 1, return ())
+ Just (q, qs) -> return (Queued qs, q)
diff --git a/src/Development/Rattle/Server.hs b/src/Development/Rattle/Server.hs
new file mode 100644
--- /dev/null
+++ b/src/Development/Rattle/Server.hs
@@ -0,0 +1,274 @@
+{-# LANGUAGE ScopedTypeVariables, RecordWildCards, TupleSections, ViewPatterns, LambdaCase #-}
+
+module Development.Rattle.Server(
+ RattleOptions(..), rattleOptions,
+ Rattle, withRattle,
+ Hazard,
+ cmdRattle
+ ) where
+
+import Control.Monad.Extra
+import Development.Rattle.Limit
+import Development.Rattle.Types
+import Development.Rattle.Shared
+import Development.Rattle.Hash
+import Control.Exception.Extra
+import Control.Concurrent.Extra
+import General.Extra
+import System.FilePath
+import qualified Data.ByteString.Char8 as BS
+import System.IO.Unsafe(unsafeInterleaveIO)
+import qualified Development.Shake.Command as C
+import qualified Data.HashMap.Strict as Map
+import qualified Data.HashSet as Set
+import Data.IORef
+import Data.Hashable
+import Data.List.Extra
+import Data.Tuple.Extra
+
+
+-- | Basic options for configuring rattle.
+data RattleOptions = RattleOptions
+ {rattleFiles :: FilePath -- ^ Where all my shared files go
+ ,rattleSpeculate :: Maybe String -- ^ Should I speculate? Under which key?
+ ,rattleShare :: Bool -- ^ Should I share files from the cache
+ ,rattleProcesses :: Int -- ^ Number of simulateous processes
+ } deriving Show
+
+-- | Default 'RattleOptions' value.
+rattleOptions :: RattleOptions
+rattleOptions = RattleOptions ".rattle" (Just "") True 8
+
+data ReadOrWrite = Read | Write deriving (Show,Eq)
+
+data S = S
+ {timestamp :: !T
+ -- ^ The current timestamp we are on
+ ,started :: Map.HashMap Cmd (NoShow (IO ()))
+ -- ^ Things that have got to running - if you find a duplicate just run the IO
+ -- to wait for it.
+ ,running :: [(T, Cmd, [Trace ()])]
+ -- ^ Things currently running, with the time they started,
+ -- and an amalgamation of their previous Trace (if we have any)
+ ,hazard :: Map.HashMap FilePath (ReadOrWrite, T, Cmd)
+ -- ^ Things that have been read or written, at what time, and by which command
+ -- Used to detect hazards.
+ -- Read is recorded as soon as it can, Write as late as it can, as that increases hazards.
+ ,pending :: [(T, Cmd, Trace Hash)]
+ -- ^ Things that have completed, and would like to get recorded, but have to wait
+ -- to confirm they didn't cause hazards
+ ,required :: [Cmd]
+ -- ^ Things what were required by the user calling cmdRattle, not added due to speculation.
+ -- Will be the 'speculate' list next time around.
+ } deriving Show
+
+
+data Problem
+ = Finished
+ | Hazard Hazard
+
+throwProblem :: Problem -> IO a
+throwProblem Finished = fail "Finished, but still trying to do stuff"
+throwProblem (Hazard h) = throwIO h
+
+-- | Type of exception thrown if there is a hazard when running the build system.
+data Hazard
+ = ReadWriteHazard FilePath Cmd Cmd
+ | WriteWriteHazard FilePath Cmd Cmd
+ deriving Show
+instance Exception Hazard
+
+
+data Rattle = Rattle
+ {options :: RattleOptions
+ ,speculate :: [(Cmd, [Trace Hash])] -- ^ Things that were used in the last speculation with this name
+ ,state :: Var (Either Problem S)
+ ,speculated :: IORef Bool
+ ,limit :: Limit
+ ,shared :: Shared
+ }
+
+
+withRattle :: RattleOptions -> (Rattle -> IO a) -> IO a
+withRattle options@RattleOptions{..} act = withShared rattleFiles $ \shared -> do
+ speculate <- maybe (return []) (getSpeculate shared) rattleSpeculate
+ speculate <- fmap (takeWhile (not . null . snd)) $ forM speculate $ \x -> (x,) <$> unsafeInterleaveIO (getCmdTraces shared x)
+ speculated <- newIORef False
+ let s0 = Right $ S t0 Map.empty [] Map.empty [] []
+ state <- newVar s0
+ limit <- newLimit rattleProcesses
+ let r = Rattle{..}
+ runSpeculate r
+
+ let saveSpeculate state =
+ whenJust rattleSpeculate $ \name ->
+ whenRightM (readVar state) $ \v ->
+ setSpeculate shared name $ reverse $ required v
+
+ -- first try and run it
+ ((act r <* saveSpeculate state) `finally` writeVar state (Left Finished)) `catch`
+ \(h :: Hazard) -> do
+ b <- readIORef speculated
+ if not b then throwIO h else do
+ -- if we speculated, and we failed with a hazard, try again
+ putStrLn "Warning: Speculation lead to a hazard, retrying without speculation"
+ print h
+ state <- newVar s0
+ limit <- newLimit rattleProcesses
+ let r = Rattle{speculate=[], ..}
+ (act r <* saveSpeculate state) `finally` writeVar state (Left Finished)
+
+
+runSpeculate :: Rattle -> IO ()
+runSpeculate rattle@Rattle{..} = void $ withLimitMaybe limit $ forkIO $
+ -- speculate on a process iff it is the first process in speculate that:
+ -- 1) we have some parallelism free
+ -- 2) it is the first eligible in the list
+ -- 3) not already been started
+ -- 4) no read/write conflicts with anything completed
+ -- 5) no read conflicts with anything running or any earlier speculation
+ join $ modifyVar state $ \s -> case s of
+ Right s | Just cmd <- nextSpeculate rattle s -> do
+ writeIORef speculated True
+ cmdRattleStarted rattle cmd s ["speculating"]
+ _ -> return (s, return ())
+
+
+nextSpeculate :: Rattle -> S -> Maybe Cmd
+nextSpeculate Rattle{..} S{..}
+ | any (null . thd3) running = Nothing
+ | otherwise = step (addTrace (Set.empty, Set.empty) $ mconcat $ concatMap thd3 running) speculate
+ where
+ addTrace (r,w) Trace{..} = (f r tRead, f w tWrite)
+ where f set xs = Set.union set $ Set.fromList $ map fst xs
+
+ step _ [] = Nothing
+ step rw ((x,_):xs)
+ | x `Map.member` started = step rw xs -- do not update the rw, since its already covered
+ step rw@(r, w) ((x, mconcat -> t@Trace{..}):xs)
+ | not $ any (\v -> v `Set.member` r || v `Set.member` w || v `Map.member` hazard) $ map fst tWrite
+ -- if anyone I write has ever been read or written, or might be by an ongoing thing, that would be bad
+ , not $ any (`Set.member` w) $ map fst tRead
+ -- if anyone I read might be being written right now, that would be bad
+ = Just x
+ | otherwise
+ = step (addTrace rw t) xs
+
+
+cmdRattle :: Rattle -> [String] -> IO ()
+cmdRattle rattle args = cmdRattleRequired rattle $ Cmd args
+
+cmdRattleRequired :: Rattle -> Cmd -> IO ()
+cmdRattleRequired rattle@Rattle{..} cmd = withLimit limit $ do
+ modifyVar_ state $ return . fmap (\s -> s{required = cmd : required s})
+ cmdRattleStart rattle cmd
+
+cmdRattleStart :: Rattle -> Cmd -> IO ()
+cmdRattleStart rattle@Rattle{..} cmd = join $ modifyVar state $ \case
+ Left e -> throwProblem e
+ Right s -> cmdRattleStarted rattle cmd s []
+
+cmdRattleStarted :: Rattle -> Cmd -> S -> [String] -> IO (Either Problem S, IO ())
+cmdRattleStarted rattle@Rattle{..} cmd s msgs = do
+ let start = timestamp s
+ s <- return s{timestamp = succ $ timestamp s}
+ case Map.lookup cmd (started s) of
+ Just (NoShow wait) -> return (Right s, wait)
+ Nothing -> do
+ hist <- unsafeInterleaveIO $ getCmdTraces shared cmd
+ go <- once $ cmdRattleRun rattle cmd start hist msgs
+ s <- return s{running = (start, cmd, map void hist) : running s}
+ s <- return s{started = Map.insert cmd (NoShow go) $ started s}
+ return (Right s, runSpeculate rattle >> go >> runSpeculate rattle)
+
+
+-- either fetch it from the cache or run it)
+cmdRattleRun :: Rattle -> Cmd -> T -> [Trace Hash] -> [String] -> IO ()
+cmdRattleRun rattle@Rattle{..} cmd@(Cmd args) start hist msgs = do
+ hasher <- memoIO hashFile
+ let match (fp, h) = (== Just h) <$> hasher fp
+ histRead <- filterM (allM match . tRead) hist
+ histBoth <- filterM (allM match . tWrite) histRead
+ case histBoth of
+ t:_ ->
+ -- we have something consistent at this point, no work to do
+ -- technically we aren't writing to the tWrite part of the trace, but if we don't include that
+ -- skipping can turn write/write hazards into read/write hazards
+ cmdRattleFinished rattle start cmd t False
+ [] -> do
+ -- lets see if any histRead's are also available in the cache
+ fetcher <- memoIO $ getFile shared
+ let fetch (fp, h) = do v <- fetcher h; case v of Nothing -> return Nothing; Just op -> return $ Just $ op fp
+ download <- if not (rattleShare options)
+ then return Nothing
+ else firstJustM (\t -> fmap (t,) <$> allMaybeM fetch (tWrite t)) histRead
+ case download of
+ Just (t, download) -> do
+ display ["copying"]
+ sequence_ download
+ cmdRattleFinished rattle start cmd t False
+ Nothing -> do
+ display []
+ t <- fsaTrace <$> C.cmd args
+ let skip x = "/dev/" `isPrefixOf` x || hasTrailingPathSeparator x
+ let f xs = mapMaybeM (\x -> fmap (x,) <$> hashFile x) $ filter (not . skip) $ map fst xs
+ t <- Trace <$> f (tRead t) <*> f (tWrite t)
+ when (rattleShare options) $
+ forM_ (tWrite t) $ \(fp, h) ->
+ setFile shared fp h ((== Just h) <$> hashFile fp)
+ cmdRattleFinished rattle start cmd t True
+ where
+ display msgs2 = BS.putStrLn $ BS.pack $ unwords $ "#" : args ++ ["(" ++ unwords (msgs ++ msgs2) ++ ")" | not $ null $ msgs ++ msgs2]
+
+-- | I finished running a command
+cmdRattleFinished :: Rattle -> T -> Cmd -> Trace Hash -> Bool -> IO ()
+cmdRattleFinished rattle@Rattle{..} start cmd trace@Trace{..} save = join $ modifyVar state $ \case
+ Left e -> throwProblem e
+ Right s -> do
+ -- update all the invariants
+ let stop = timestamp s
+ s <- return s{timestamp = succ $ timestamp s}
+ s <- return s{running = filter ((/= start) . fst3) $ running s}
+ s <- return s{pending = [(stop, cmd, trace) | save] ++ pending s}
+
+ -- look for hazards
+ let newHazards = Map.fromList $ map ((,(Write,start,cmd)) . fst) tWrite ++
+ map ((,(Read ,stop ,cmd)) . fst) tRead
+ case unionWithKeyEithers mergeFileOps (hazard s) newHazards of
+ (ps@(p:_), _) -> return (Left $ Hazard p, print ps >> throwIO p)
+ ([], hazard2) -> do
+ s <- return s{hazard = hazard2}
+
+ -- move people out of pending if they have survived long enough
+ let earliest = minimum $ succ stop : map fst3 (running s)
+ (safe, pending) <- return $ partition (\x -> fst3 x < earliest) $ pending s
+ s <- return s{pending = pending}
+ return (Right s, forM_ safe $ \(_,c,t) -> addCmdTrace shared c t)
+
+
+mergeFileOps :: FilePath -> (ReadOrWrite, T, Cmd) -> (ReadOrWrite, T, Cmd) -> Either Hazard (ReadOrWrite, T, Cmd)
+mergeFileOps x (Read, t1, cmd1) (Read, t2, cmd2) = Right (Read, min t1 t2, if t1 < t2 then cmd1 else cmd2)
+mergeFileOps x (Write, t1, cmd1) (Write, t2, cmd2) = Left $ WriteWriteHazard x cmd1 cmd2
+mergeFileOps x (Read, t1, cmd1) (Write, t2, cmd2)
+ | t1 <= t2 = Left $ ReadWriteHazard x cmd2 cmd1
+ | otherwise = Right (Write, t2, cmd2)
+mergeFileOps x v1 v2 = mergeFileOps x v2 v1 -- must be Write/Read, so match the other way around
+
+
+allMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m (Maybe [b])
+allMaybeM f [] = return $ Just []
+allMaybeM f (x:xs) = do
+ y <- f x
+ case y of
+ Nothing -> return Nothing
+ Just y -> fmap (y:) <$> allMaybeM f xs
+
+
+unionWithKeyEithers :: (Eq k, Hashable k) => (k -> v -> v -> Either e v) -> Map.HashMap k v -> Map.HashMap k v -> ([e], Map.HashMap k v)
+unionWithKeyEithers op lhs rhs = foldl' f ([], lhs) $ Map.toList rhs
+ where
+ f (es, mp) (k, v2) = case Map.lookup k mp of
+ Nothing -> (es, Map.insert k v2 mp)
+ Just v1 -> case op k v1 v2 of
+ Left e -> (e:es, mp)
+ Right v -> (es, Map.insert k v mp)
diff --git a/src/Development/Rattle/Shared.hs b/src/Development/Rattle/Shared.hs
new file mode 100644
--- /dev/null
+++ b/src/Development/Rattle/Shared.hs
@@ -0,0 +1,80 @@
+{-# LANGUAGE ViewPatterns #-}
+
+module Development.Rattle.Shared(
+ Shared, withShared,
+ getSpeculate, setSpeculate,
+ getFile, setFile,
+ getCmdTraces, addCmdTrace
+ ) where
+
+import General.Extra
+import Development.Rattle.Types
+import Development.Rattle.Hash
+import System.FilePath
+import System.Directory
+import System.IO.Extra
+import Data.Maybe
+import Control.Monad.Extra
+import Text.Read
+import Control.Concurrent.Extra
+
+
+data Shared = Shared Lock FilePath
+
+withShared :: FilePath -> (Shared -> IO a) -> IO a
+withShared dir act = do
+ lock <- newLock
+ createDirectoryRecursive dir
+ act $ Shared lock dir
+
+filename :: Hash -> String
+filename (fromHash -> a:b:cs) = [a,b] cs
+
+getList :: (Show a, Read b) => String -> Shared -> a -> IO [b]
+getList typ (Shared lock dir) name = withLock lock $ do
+ let file = dir typ filename (hashString $ show name)
+ b <- doesFileExist file
+ if not b then return [] else mapMaybe readMaybe . lines <$> readFileUTF8' file
+
+setList :: (Show a, Show b) => String -> IOMode -> Shared -> a -> [b] -> IO ()
+setList typ mode (Shared lock dir) name vals = withLock lock $ do
+ let file = dir typ filename (hashString $ show name)
+ createDirectoryRecursive $ takeDirectory file
+ unlessM (doesFileExist $ file <.> "txt") $
+ writeFile (file <.> "txt") $ show name
+ withFile file mode $ \h -> do
+ hSetEncoding h utf8
+ hPutStr h $ unlines $ map show vals
+
+
+getSpeculate :: Shared -> String -> IO [Cmd]
+getSpeculate = getList "speculate"
+
+setSpeculate :: Shared -> String -> [Cmd] -> IO ()
+setSpeculate = setList "speculate" WriteMode
+
+getCmdTraces :: Shared -> Cmd -> IO [Trace Hash]
+getCmdTraces = getList "command"
+
+addCmdTrace :: Shared -> Cmd -> Trace Hash -> IO ()
+addCmdTrace share cmd t = setList "command" AppendMode share cmd [t]
+
+
+getFile :: Shared -> Hash -> IO (Maybe (FilePath -> IO ()))
+getFile (Shared lock dir) hash = do
+ let file = dir "files" filename hash
+ b <- doesFileExist file
+ return $ if not b then Nothing else Just $ copyFile file
+
+setFile :: Shared -> FilePath -> Hash -> IO Bool -> IO ()
+setFile (Shared lock dir) source hash check = do
+ let file = dir "files" filename hash
+ b <- doesFileExist file
+ unlessM (doesFileExist file) $ withLock lock $ do
+ createDirectoryRecursive $ takeDirectory file
+ copyFile source (file <.> "tmp")
+ good <- check
+ if not good then
+ removeFile $ file <.> "tmp"
+ else
+ renameFile (file <.> "tmp") file
diff --git a/src/Development/Rattle/Types.hs b/src/Development/Rattle/Types.hs
new file mode 100644
--- /dev/null
+++ b/src/Development/Rattle/Types.hs
@@ -0,0 +1,50 @@
+{-# LANGUAGE TupleSections, GeneralizedNewtypeDeriving, DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
+
+module Development.Rattle.Types(
+ Trace(..), fsaTrace,
+ Cmd(..),
+ T, t0,
+ ) where
+
+import Data.Hashable
+import Data.List.Extra
+import Development.Shake.Command
+import Data.Semigroup
+import Prelude
+
+newtype Cmd = Cmd [String]
+ deriving (Show, Read, Eq, Hashable)
+
+data Trace a = Trace
+ {tRead :: [(FilePath, a)]
+ ,tWrite :: [(FilePath, a)]
+ } deriving (Show, Read, Functor, Foldable, Traversable)
+
+instance Semigroup (Trace a) where
+ Trace r1 w1 <> Trace r2 w2 = Trace (r1++r2) (w1++w2)
+
+instance Monoid (Trace a) where
+ mempty = Trace [] []
+ mappend = (<>)
+
+
+fsaTrace :: [FSATrace] -> Trace ()
+fsaTrace = nubTrace . mconcat . map f
+ where
+ g r w = Trace (map (,()) r) (map (,()) w)
+ f (FSAWrite x) = g [] [x]
+ f (FSARead x) = g [x] []
+ f (FSADelete x) = g [] [x]
+ f (FSAMove x y) = g [] [x,y]
+ f (FSAQuery x) = g [x] []
+ f (FSATouch x) = g [] [x]
+
+nubTrace :: Ord a => Trace a -> Trace a
+nubTrace (Trace a b) = Trace (nubOrd a \\ b) (nubOrd b)
+
+
+newtype T = T Int -- timestamps
+ deriving (Enum,Eq,Ord,Show)
+
+t0 :: T
+t0 = T 0
diff --git a/src/General/Bilist.hs b/src/General/Bilist.hs
new file mode 100644
--- /dev/null
+++ b/src/General/Bilist.hs
@@ -0,0 +1,37 @@
+
+-- | List type that supports O(1) amortized 'cons', 'snoc', 'uncons' and 'isEmpty'.
+module General.Bilist(
+ Bilist, cons, snoc, uncons, toList, isEmpty
+ ) where
+
+import Data.Semigroup (Semigroup(..))
+
+
+data Bilist a = Bilist [a] [a]
+
+toList :: Bilist a -> [a]
+toList (Bilist as bs) = as ++ reverse bs
+
+isEmpty :: Bilist a -> Bool
+isEmpty (Bilist as bs) = null as && null bs
+
+instance Eq a => Eq (Bilist a) where
+ a == b = toList a == toList b
+
+instance Semigroup (Bilist a) where
+ a <> b = Bilist (toList a ++ toList b) []
+
+instance Monoid (Bilist a) where
+ mempty = Bilist [] []
+ mappend = (<>)
+
+cons :: a -> Bilist a -> Bilist a
+cons x (Bilist as bs) = Bilist (x:as) bs
+
+snoc :: Bilist a -> a -> Bilist a
+snoc (Bilist as bs) x = Bilist as (x:bs)
+
+uncons :: Bilist a -> Maybe (a, Bilist a)
+uncons (Bilist [] []) = Nothing
+uncons (Bilist (a:as) bs) = Just (a, Bilist as bs)
+uncons (Bilist [] bs) = uncons $ Bilist (reverse bs) []
diff --git a/src/General/Extra.hs b/src/General/Extra.hs
new file mode 100644
--- /dev/null
+++ b/src/General/Extra.hs
@@ -0,0 +1,69 @@
+
+module General.Extra(
+ whenLeft,
+ whenRightM,
+ createDirectoryRecursive,
+ NoShow(..),
+ memoIO
+ ) where
+
+import Control.Exception.Extra
+import System.Directory
+import Data.IORef
+import qualified Data.HashMap.Strict as Map
+import Data.Hashable
+import Control.Monad
+
+
+---------------------------------------------------------------------
+-- Prelude
+
+newtype NoShow a = NoShow a
+instance Show (NoShow a) where show _ = "NoShow"
+
+
+---------------------------------------------------------------------
+-- Control.Monad
+
+whenRightM :: Monad m => m (Either l r) -> (r -> m ()) -> m ()
+whenRightM x act = either (const $ return ()) act =<< x
+
+
+---------------------------------------------------------------------
+-- Control.Exception
+
+tryIO :: IO a -> IO (Either IOException a)
+tryIO = try
+
+
+---------------------------------------------------------------------
+-- System.Directory
+
+-- | Like @createDirectoryIfMissing True@ but faster, as it avoids
+-- any work in the common case the directory already exists.
+createDirectoryRecursive :: FilePath -> IO ()
+createDirectoryRecursive dir = do
+ x <- tryIO $ doesDirectoryExist dir
+ when (x /= Right True) $ createDirectoryIfMissing True dir
+
+
+---------------------------------------------------------------------
+-- Data.Either
+
+whenLeft :: Applicative m => Either a b -> (a -> m ()) -> m ()
+whenLeft x f = either f (const $ pure ()) x
+
+
+---------------------------------------------------------------------
+-- Data.Memo
+
+memoIO :: (Hashable k, Eq k) => (k -> IO v) -> IO (k -> IO v)
+memoIO f = do
+ ref <- newIORef Map.empty
+ return $ \k -> do
+ mp <- readIORef ref
+ case Map.lookup k mp of
+ Just v -> return v
+ Nothing -> do
+ v <- f k
+ atomicModifyIORef ref $ \mp -> (Map.insert k v mp, v)
diff --git a/src/General/Thread.hs b/src/General/Thread.hs
new file mode 100644
--- /dev/null
+++ b/src/General/Thread.hs
@@ -0,0 +1,47 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
+-- | A bit like 'Fence', but not thread safe and optimised for avoiding taking the fence
+module General.Thread(
+ withThreadsList,
+ ) where
+
+import Control.Concurrent.Extra
+import Control.Exception
+import General.Extra
+import Control.Monad.Extra
+
+
+-- Run both actions. If either throws an exception, both threads
+-- are killed and an exception reraised.
+-- Not called much, so simplicity over performance (2 threads).
+withThreadsBoth :: IO a -> IO b -> IO (a, b)
+withThreadsBoth act1 act2 = do
+ bar1 <- newBarrier
+ bar2 <- newBarrier
+ parent <- myThreadId
+ ignore <- newVar False
+ mask $ \unmask -> do
+ t1 <- forkIOWithUnmask $ \unmask -> do
+ res1 :: Either SomeException a <- try $ unmask act1
+ unlessM (readVar ignore) $ whenLeft res1 $ throwTo parent
+ signalBarrier bar1 res1
+ t2 <- forkIOWithUnmask $ \unmask -> do
+ res2 :: Either SomeException b <- try $ unmask act2
+ unlessM (readVar ignore) $ whenLeft res2 $ throwTo parent
+ signalBarrier bar2 res2
+ res :: Either SomeException (a,b) <- try $ unmask $ do
+ Right v1 <- waitBarrier bar1
+ Right v2 <- waitBarrier bar2
+ return (v1,v2)
+ writeVar ignore True
+ killThread t1
+ forkIO $ killThread t2
+ waitBarrier bar1
+ waitBarrier bar2
+ either throwIO return res
+
+
+withThreadsList :: [IO a] -> IO [a]
+withThreadsList [] = return []
+withThreadsList [x] = (:[]) <$> x
+withThreadsList (x:xs) = uncurry (:) <$> withThreadsBoth x (withThreadsList xs)
diff --git a/test/C/constants.c b/test/C/constants.c
new file mode 100644
--- /dev/null
+++ b/test/C/constants.c
@@ -0,0 +1,7 @@
+
+char msg[] = "Hello Rattle Users!";
+
+char* message()
+{
+ return msg;
+}
diff --git a/test/C/constants.h b/test/C/constants.h
new file mode 100644
--- /dev/null
+++ b/test/C/constants.h
@@ -0,0 +1,1 @@
+char* message();
diff --git a/test/C/main.c b/test/C/main.c
new file mode 100644
--- /dev/null
+++ b/test/C/main.c
@@ -0,0 +1,8 @@
+#include
+#include "constants.h"
+
+int main()
+{
+ printf("%s\n", message());
+ return 0;
+}
diff --git a/test/Test.hs b/test/Test.hs
new file mode 100644
--- /dev/null
+++ b/test/Test.hs
@@ -0,0 +1,52 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Test(main) where
+
+import Development.Rattle
+import System.FilePattern.Directory
+import Development.Shake.FilePath
+import Control.Exception
+import System.Directory
+import System.Info.Extra
+import Control.Monad.Extra
+
+
+withOutput :: (FilePath -> IO a) -> IO a
+withOutput act = do
+ ignoreIO $ removeDirectoryRecursive "output"
+ createDirectoryIfMissing True "output"
+ withCurrentDirectory "output" $ act ".."
+
+ignoreIO :: IO () -> IO ()
+ignoreIO act = catch act $ \(_ :: IOException) -> return ()
+
+
+-- Don't run on Mac because of https://github.com/jacereda/fsatrace/issues/25
+main = unless isMac $ withOutput $ \root -> do
+ let wipe = mapM (ignoreIO . removeFile) =<< getDirectoryFiles "." ["*"]
+ cs <- liftIO $ getDirectoryFiles "." [root "test/C/*.c"]
+ let toO x = takeBaseName x <.> "o"
+ let build = do
+ forM_ cs $ \c -> cmd ["gcc","-o",toO c,"-c",c]
+ cmd $ ["gcc","-o","Main" <.> exe] ++ map toO cs
+ cmd ["./Main" <.> exe]
+
+ putStrLn "Build 1: Expect everything"
+ rattle rattleOptions build
+ putStrLn "Build 2: Expect nothing"
+ rattle rattleOptions build
+ wipe
+ putStrLn "Build 3: Expect cached (some speculation)"
+ rattle rattleOptions build
+
+
+ putStrLn "Build 4: Read/write hazard"
+ handle (\(h :: Hazard) -> print h) $ do
+ rattle rattleOptions{rattleSpeculate=Nothing} $ do
+ cmd ["./Main" <.> exe]
+ cmd $ ["gcc","-o","Main" <.> exe] ++ reverse (map toO cs)
+ putStrLn "Hoped it failed, but doesn't always"
+ -- fail "Expected a hazard"
+
+ putStrLn "Build 5: Rebuild after"
+ rattle rattleOptions build