git.iko.soy/obelisk
on master help sign in
Merge pull request #3 from obsidiansystems/cache-nix-builds

Cache nix-build of project-specific obelisk-command

commite646a7de2b72b3184bcbed84453d5351a994533b authorRyan Trinkle <ryan.trinkle@gmail.com> dateWed 3 Jan 2018, 17:28 (9 years ago) parent3cb368ea9efb4a
3 files changed+59−31
compare with master
unifiedsplit
command/obelisk-command.cabal+1 command/src/Obelisk/Command/Project.hs+8−28 command/src/Obelisk/Command/Thunk.hs+50−3
command/obelisk-command.cabal+1
@@ -18,6 +18,7 @@ library
1818 , optparse-applicative
1919 , process
2020 , text
21+ , time
2122 , transformers
2223 , unix
2324 , yaml
command/src/Obelisk/Command/Project.hs+8−28
@@ -6,21 +6,21 @@ module Obelisk.Command.Project
66 ) where
77
88import Control.Monad
9+import Control.Monad.IO.Class
10+import Control.Monad.Trans.State
911import Data.Bits
10−import qualified Data.ByteString.Lazy as LBS
1112import Data.Function (on)
1213import Data.Monoid
1314import qualified Data.Text as T
1415import qualified Data.Text.IO as T
15−import Obelisk.Command.Thunk
1616import System.Directory
17−import System.Exit
1817import System.FilePath
1918import System.IO
20−import System.Posix (FileStatus, getFileStatus, deviceID, fileID, getRealUserID, fileOwner, fileMode)
21−import System.Process
22−import Control.Monad.IO.Class
23−import Control.Monad.Trans.State
19+import System.Posix (FileStatus, getFileStatus , deviceID, fileID, getRealUserID , fileOwner, fileMode)
20+
21+import Obelisk.Command.Thunk
22+
23+--TODO: Make this module resilient to random exceptions
2424
2525--TODO: Don't hardcode this
2626-- | Source for the Obelisk project
@@ -38,26 +38,6 @@ initProject target = do
3838 createDirectory obDir
3939 createThunkWithLatest (obDir </> "impl") obeliskSource
4040
41−nixBuildDashA :: FilePath -> String -> IO FilePath
42−nixBuildDashA path attr = do
43− -- We need to keep 'err' around, because nix-build seems to crash if it runs
44− -- for long enough and we've let 'err' die. It's probably dying from the
45− -- closed output pipe, but I haven't investigated. The code below that
46− -- outputs the contents of 'err' when an error is hit is sufficient to keep it
47− -- alive.
48− (_, out, err, p) <- runInteractiveProcess "nix-build" --TODO: Make this package depend on nix-prefetch-url properly
49− [ "--no-out-link"
50− , path
51− , "-A"
52− , attr
53− ] Nothing Nothing
54− waitForProcess p >>= \case
55− ExitSuccess -> return ()
56− _ -> do
57− LBS.putStr =<< LBS.hGetContents err
58− fail "nix-build failed"
59− T.unpack . T.strip <$> T.hGetContents out
60−
6141--TODO: Handle errors
6242--TODO: Allow the user to ignore our security concerns
6343-- | Find the Obelisk implementation for the project at the given path
@@ -99,7 +79,7 @@ findProjectObeliskCommand target = do
9979 (result, insecurePaths) <- runStateT (findImpl target targetStat) []
10080 case (result, insecurePaths) of
10181 (Just projDir, []) -> do
102− obeliskCommandPkg <- nixBuildDashA (projDir </> ".obelisk" </> "impl") "command"
82+ obeliskCommandPkg <- nixBuildThunkAttrWithCache (projDir </> ".obelisk" </> "impl") "command"
10383 return $ Just $ obeliskCommandPkg </> "bin" </> "ob"
10484 (Nothing, _) -> return Nothing
10585 (Just projDir, _) -> do
command/src/Obelisk/Command/Thunk.hs+50−3
@@ -9,24 +9,26 @@ module Obelisk.Command.Thunk
99 , getLatestRev
1010 , updateThunkToLatest
1111 , createThunkWithLatest
12+ , nixBuildThunkAttrWithCache
1213 ) where
1314
1415import Control.Exception
1516import Control.Monad
16−import qualified Data.ByteString.Lazy as LBS
1717import Data.Aeson as Aeson
1818import Data.Aeson.Encode.Pretty
19+import qualified Data.ByteString.Lazy as LBS
1920import Data.Foldable
2021import Data.Git.Ref (Ref)
2122import qualified Data.Git.Ref as Ref
22−import Data.Maybe
23−import Data.Monoid
2423import Data.List.NonEmpty (NonEmpty (..))
2524import qualified Data.List.NonEmpty as NonEmpty
25+import Data.Maybe
26+import Data.Monoid
2627import Data.Text (Text)
2728import qualified Data.Text as T
2829import qualified Data.Text.IO as T
2930import Data.Text.Encoding
31+import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
3032import Data.Yaml (parseMaybe, (.:))
3133import qualified Data.Yaml as Yaml
3234import GitHub
@@ -36,6 +38,9 @@ import Network.URI
3638import System.Directory
3739import System.Exit
3840import System.FilePath
41+import System.IO
42+import System.IO.Error
43+import System.Posix (modificationTime, getSymbolicLinkStatus)
3944import System.Process
4045
4146-- | A reference to the exact data that a thunk should translate into
@@ -241,3 +246,45 @@ getHubAuth domain = do
241246 return $ OAuth $ encodeUtf8 token
242247
243248--TODO: when checking something out, make a shallow clone
249+
250+-- | Checks a cache directory to see if there is a fresh symlink
251+-- to the result of building an attribute of a thunk.
252+-- If no cache hit is found, nix-build is called to build the attribute
253+-- and the result is symlinked into the cache.
254+nixBuildThunkAttrWithCache :: FilePath
255+ -- ^ Path to directory containing Thunk
256+ -> String
257+ -- ^ Attribute to build
258+ -> IO FilePath
259+ -- ^ Symlink to cached or built nix output
260+-- WARNING: If the thunk uses an impure reference such as '<nixpkgs>'
261+-- the caching mechanism will fail as it merely measures the modification
262+-- time of the cache link and the expression to build.
263+nixBuildThunkAttrWithCache thunkDir attr = do
264+ let cacheErrHandler e
265+ | isDoesNotExistError e = return Nothing -- expected from a cache miss
266+ | otherwise = hPutStrLn stderr (displayException e) >> return Nothing
267+ cacheDir = thunkDir </> ".attr-cache"
268+ cachePath = cacheDir </> attr <.> "out"
269+ createDirectoryIfMissing False cacheDir
270+ latestChange <- maximum <$> mapM (getModificationTime . (thunkDir </>)) ["default.nix", "github.json"]
271+ cacheHit <- handle cacheErrHandler $ do
272+ cacheTime <- posixSecondsToUTCTime . realToFrac . modificationTime <$> getSymbolicLinkStatus cachePath
273+ return $ if latestChange <= cacheTime
274+ then Just cachePath
275+ else Nothing
276+ case cacheHit of
277+ Just c -> return c
278+ Nothing -> do
279+ hPutStrLn stderr (mconcat [ thunkDir, ":", attr, " not cached, building ..."])
280+ (_, _, err, p) <- runInteractiveProcess "nix-build"
281+ [ thunkDir
282+ , "-A", attr
283+ , "--indirect", "--add-root", cachePath
284+ ] Nothing Nothing
285+ waitForProcess p >>= \case
286+ ExitSuccess -> return ()
287+ _ -> do
288+ LBS.putStr =<< LBS.hGetContents err
289+ fail "nix-build failed"
290+ return cachePath