@@ -9,14 +9,16 @@ module Obelisk.Command.Thunk
99 , getLatestRev
1010 , updateThunkToLatest
1111 , createThunkWithLatest
12− , nixBuildThunkAttrWithCache
12+ , nixBuildAttrWithCache
1313 ) where
1414
1515import Control.Exception
1616import Control.Monad
17+import Control.Monad.Except
1718import Data.Aeson as Aeson
1819import Data.Aeson.Encode.Pretty
1920import qualified Data.ByteString.Lazy as LBS
21+import Data.Default
2022import Data.Foldable
2123import Data.Git.Ref (Ref)
2224import qualified Data.Git.Ref as Ref
@@ -24,6 +26,7 @@ import Data.List.NonEmpty (NonEmpty (..))
2426import qualified Data.List.NonEmpty as NonEmpty
2527import Data.Maybe
2628import Data.Monoid
29+import Data.Set (Set)
2730import qualified Data.Set as Set
2831import Data.Text (Text)
2932import qualified Data.Text as T
@@ -36,6 +39,7 @@ import GitHub
3639import GitHub.Endpoints.Repos.Contents (archiveForR)
3740import GitHub.Data.Name
3841import Network.URI
42+import Obelisk.Command.Nix
3943import System.Directory
4044import System.Exit
4145import System.FilePath
@@ -109,10 +113,15 @@ getLatestRev = \case
109113 , _thunkRev_nixSha256 = nixSha256
110114 }
111115
116+data ReadThunkError
117+ = ReadThunkError_WrongContents (Set String) (Set String)
118+ | ReadThunkError_UnrecognizedLoader Text
119+ | ReadThunkError_UnparseablePtr LBS.ByteString
120+
112121-- | Read a thunk and validate that it is only a thunk. If additional data is
113122-- present, fail.
114−readThunk :: FilePath -> IO (Maybe ThunkPtr)
115−readThunk thunkDir = do
123+readThunk :: FilePath -> IO (Either ReadThunkError ThunkPtr)
124+readThunk thunkDir = runExceptT $ do
116125 let thunkLoader = thunkDir </> "default.nix"
117126 githubJson = thunkDir </> "github.json"
118127 attrCache = thunkDir </> ".attr-cache"
@@ -124,16 +133,18 @@ readThunk thunkDir = do
124133
125134 -- Ensure that there aren't any other files in the thunk
126135 -- NB: System.Directory.listDirectory returns the contents without the directory path
127− files <- Set.fromList . fmap (thunkDir </>) <$> listDirectory thunkDir
136+ files <- liftIO $ Set.fromList . fmap (thunkDir </>) <$> listDirectory thunkDir
128137 let unexpectedContents = files `Set.difference` expectedContents
129138 missingContents = expectedContents `Set.difference` files
130− guard $ Set.null unexpectedContents && Set.null missingContents
139+ unless (Set.null unexpectedContents && Set.null missingContents) $ do
140+ throwError $ ReadThunkError_WrongContents unexpectedContents missingContents
131141
132142 -- Ensure that we recognize the thunk loader
133− loader <- T.readFile thunkLoader
134− guard $ loader `elem` gitHubStandaloneLoaders
143+ loader <- liftIO $ T.readFile thunkLoader
144+ unless (loader `elem` gitHubStandaloneLoaders) $ do
145+ throwError $ ReadThunkError_UnrecognizedLoader loader
135146
136− txt <- LBS.readFile githubJson
147+ txt <- liftIO $ LBS.readFile githubJson
137148 let p v = do
138149 owner <- v Aeson..: "owner"
139150 repo <- v Aeson..: "repo"
@@ -153,12 +164,14 @@ readThunk thunkDir = do
153164 , _gitHubSource_private = fromMaybe False mPrivate
154165 }
155166 }
156− return $ parseMaybe p =<< decode txt
167+ case parseMaybe p =<< decode txt of
168+ Nothing -> throwError $ ReadThunkError_UnparseablePtr txt
169+ Just ptr -> return ptr
157170
158171overwriteThunk :: FilePath -> ThunkPtr -> IO ()
159172overwriteThunk target thunk = do
160173 -- Ensure that this directory is a valid thunk (i.e. so we aren't losing any data)
161− Just _ <- readThunk target
174+ Right _ <- readThunk target
162175
163176 --TODO: Is there a safer way to do this overwriting?
164177 removeDirectoryRecursive target
@@ -208,7 +221,7 @@ createThunkWithLatest target s = do
208221
209222updateThunkToLatest :: FilePath -> IO ()
210223updateThunkToLatest target = do
211− Just ptr <- readThunk target
224+ Right ptr <- readThunk target
212225 let src = _thunkPtr_source ptr
213226 rev <- getLatestRev src
214227 overwriteThunk target $ ThunkPtr
@@ -285,15 +298,30 @@ nixBuildThunkAttrWithCache thunkDir attr = do
285298 case cacheHit of
286299 Just c -> return c
287300 Nothing -> do
288− hPutStrLn stderr (mconcat [ thunkDir, ":", attr, " not cached, building ..."])
289− (_, _, err, p) <- runInteractiveProcess "nix-build"
290− [ thunkDir
291− , "-A", attr
292− , "--indirect", "--add-root", cachePath
293− ] Nothing Nothing
294− waitForProcess p >>= \case
295− ExitSuccess -> return ()
296− _ -> do
297− LBS.putStr =<< LBS.hGetContents err
298− fail "nix-build failed"
301+ hPutStrLn stderr (mconcat [thunkDir, ": ", attr, " not cached, building ..."])
302+ _ <- nixBuild $ def
303+ { _nixBuildConfig_target = Target
304+ { _target_path = thunkDir
305+ , _target_attr = Just attr
306+ }
307+ , _nixBuildConfig_outLink = OutLink_IndirectRoot cachePath
308+ }
299309 return cachePath
310+
311+-- | Build a nix attribute, and cache the result if possible
312+nixBuildAttrWithCache :: FilePath
313+ -- ^ Path to directory containing Thunk
314+ -> String
315+ -- ^ Attribute to build
316+ -> IO FilePath
317+ -- ^ Symlink to cached or built nix output
318+nixBuildAttrWithCache exprPath attr = do
319+ readThunk exprPath >>= \case
320+ Right _ -> nixBuildThunkAttrWithCache exprPath attr
321+ Left _ -> nixBuild $ def
322+ { _nixBuildConfig_target = Target
323+ { _target_path = exprPath
324+ , _target_attr = Just attr
325+ }
326+ , _nixBuildConfig_outLink = OutLink_None
327+ }