@@ -21,14 +21,12 @@ import Data.Aeson ((.=))
2121import qualified Data.Aeson as Aeson
2222import Data.Aeson.Encode.Pretty
2323import qualified Data.Aeson.Types as Aeson
24−import Data.Bifunctor (first)
2524import qualified Data.ByteString.Lazy as LBS
2625import Data.Containers.ListUtils (nubOrd)
2726import Data.Default
2827import Data.Either.Combinators (fromRight', rightToMaybe)
2928import Data.Foldable (toList)
3029import Data.Function ((&))
31−import Data.Functor ((<&>))
3230import Data.Git.Ref (Ref)
3331import qualified Data.Git.Ref as Ref
3432import qualified Data.List as L
@@ -56,7 +54,7 @@ import System.Exit
5654import System.FilePath
5755import System.IO.Error
5856import System.IO.Temp
59−import System.PosixCompat.Files (getSymbolicLinkStatus, modificationTime)
57+import System.Posix (getSymbolicLinkStatus, modificationTime)
6058import qualified Text.URI as URI
6159
6260import Obelisk.App (MonadObelisk)
@@ -65,9 +63,9 @@ import Obelisk.Command.Utils
6563
6664--TODO: Support symlinked thunk data
6765data ThunkData
68− = ThunkData_Packed ThunkSpec ThunkPtr
66+ = ThunkData_Packed (ThunkSpec, ThunkPtr)
6967 -- ^ Packed thunk
70− | ThunkData_Checkout
68+ | ThunkData_Checkout (Maybe (ThunkSpec, ThunkPtr))
7169 -- ^ Checked out thunk that was unpacked from this pointer
7270
7371-- | A reference to the exact data that a thunk should translate into
@@ -94,11 +92,6 @@ data ThunkSource
9492 | ThunkSource_Git GitSource
9593 deriving (Show, Eq, Ord)
9694
97−thunkSourceToGitSource :: ThunkSource -> GitSource
98−thunkSourceToGitSource = \case
99− ThunkSource_GitHub s -> forgetGithub False s
100− ThunkSource_Git s -> s
101−
10295data GitHubSource = GitHubSource
10396 { _gitHubSource_owner :: Name Owner
10497 , _gitHubSource_repo :: Name Repo
@@ -178,14 +171,14 @@ getNixSha256ForUriUnpacked
178171getNixSha256ForUriUnpacked uri =
179172 withExitFailMessage ("nix-prefetch-url: Failed to determine sha256 hash of URL " <> gitUriToText uri) $ do
180173 [hash] <- fmap T.lines $ readProcessAndLogOutput (Debug, Debug) $
181− proc nixPrefetchUrlPath ["--unpack", "--type", "sha256", T.unpack $ gitUriToText uri]
174+ proc "nix-prefetch-url" ["--unpack", "--type", "sha256", T.unpack $ gitUriToText uri]
182175 pure hash
183176
184177nixPrefetchGit :: MonadObelisk m => GitUri -> Text -> Bool -> m NixSha256
185178nixPrefetchGit uri rev fetchSubmodules =
186179 withExitFailMessage ("nix-prefetch-git: Failed to determine sha256 hash of Git repo " <> gitUriToText uri <> " at " <> rev) $ do
187180 out <- readProcessAndLogStderr Debug $
188− proc nixPrefetchGitPath $ filter (/="")
181+ proc "nix-prefetch-git" $ filter (/="")
189182 [ "--url", T.unpack $ gitUriToText uri
190183 , "--rev", T.unpack rev
191184 , if fetchSubmodules then "--fetch-submodules" else ""
@@ -198,28 +191,61 @@ nixPrefetchGit uri rev fetchSubmodules =
198191
199192--TODO: Pretty print these
200193data ReadThunkError
201− = ReadThunkError_UnrecognizedThunk
202− | ReadThunkError_UnrecognizedPaths (NonEmpty FilePath)
203− | ReadThunkError_MissingPaths (NonEmpty FilePath)
204− | ReadThunkError_UnparseablePtr FilePath String
205− | ReadThunkError_FileError IOError
206− | ReadThunkError_FileDoesNotMatch FilePath Text
207− | ReadThunkError_UnrecognizedState String
208− | ReadThunkError_AmbiguousPackedState ThunkPtr ThunkPtr
209− deriving (Show)
194+ = ReadThunkError_UnrecognizedPaths (NonEmpty FilePath)
195+ | ReadThunkError_MissingPaths (NonEmpty FilePath)
196+ | ReadThunkError_UnrecognizedThunk -- TODO: Delete?
197+ | ReadThunkError_UnparseablePtr FilePath String
198+ | ReadThunkError_FileError IOError
199+ | ReadThunkError_FileDoesNotMatch FilePath Text
200+ deriving (Show)
201+
202+
203+data ThunkCheckoutPaths = ThunkCheckoutPaths
204+ { _thunkCheckoutPaths_isCheckoutIfExists :: FilePath
205+ , _thunkCheckoutPaths_origThunkPath :: FilePath
206+ } deriving (Show)
207+
208+thunkCheckoutPaths :: NonEmpty ThunkCheckoutPaths
209+thunkCheckoutPaths =
210+ ThunkCheckoutPaths
211+ { _thunkCheckoutPaths_isCheckoutIfExists = unpackedDirName
212+ , _thunkCheckoutPaths_origThunkPath = "."
213+ }
214+ :| [
215+ ThunkCheckoutPaths
216+ { _thunkCheckoutPaths_isCheckoutIfExists = ".git"
217+ , _thunkCheckoutPaths_origThunkPath = ".git" </> "obelisk" </> "orig-thunk"
218+ }
219+ ]
220+
221+
222+-- | Read a thunk and validate that it is only a thunk, either packed or unpacked.
223+-- If the thunk is packed and additional data is present, fail.
224+readThunk :: MonadObelisk m => FilePath -> m (Either ReadThunkError ThunkData)
225+readThunk thunkDir = do
226+ thunkCheckout' <- liftIO $ flip findM (toList thunkCheckoutPaths) $
227+ doesPathExist . (thunkDir </>) . _thunkCheckoutPaths_isCheckoutIfExists
228+ case thunkCheckout' of
229+ Nothing -> fmap ThunkData_Packed <$> readPackedThunk thunkDir
230+ Just thunkCheckout -> do
231+ origPathExists <- liftIO $ doesDirectoryExist $ _thunkCheckoutPaths_origThunkPath thunkCheckout
232+ fmap (Right . ThunkData_Checkout) $ if origPathExists
233+ then rightToMaybe <$> readPackedThunk (thunkDir </> _thunkCheckoutPaths_origThunkPath thunkCheckout)
234+ else pure Nothing
210235
211236unpackedDirName :: FilePath
212−unpackedDirName = "."
237+unpackedDirName = "_"
213238
214239attrCacheFileName :: FilePath
215240attrCacheFileName = ".attr-cache"
216241
217242-- | Specification for how a file in a thunk version works.
218243data ThunkFileSpec
219− = ThunkFileSpec_Ptr (LBS.ByteString -> Either String ThunkPtr) -- ^ This file specifies 'ThunkPtr' data
220− | ThunkFileSpec_FileMatches Text -- ^ This file must match the given content exactly
221− | ThunkFileSpec_CheckoutIndicator -- ^ Existence of this directory indicates that the thunk is unpacked
222− | ThunkFileSpec_AttrCache -- ^ This directory is an attribute cache
244+ = ThunkFileSpec_FileMayExist
245+ | ThunkFileSpec_DirMayExist
246+ | ThunkFileSpec_AttrCache
247+ | ThunkFileSpec_Ptr (LBS.ByteString -> Either String ThunkPtr)
248+ | ThunkFileSpec_FileMatches Text
223249
224250-- | Specification for how a set of files in a thunk version work.
225251data ThunkSpec = ThunkSpec
@@ -236,7 +262,7 @@ matchThunkSpecToDir
236262 => ThunkSpec -- ^ 'ThunkSpec' to match against the given files/directory
237263 -> FilePath -- ^ Path to directory
238264 -> Set FilePath -- ^ Set of file paths relative to the given directory
239− -> m ThunkData
265+ -> m ThunkPtr
240266matchThunkSpecToDir thunkSpec dir dirFiles = do
241267 case nonEmpty (toList $ dirFiles `Set.difference` expectedPaths) of
242268 Just fs -> throwError $ ReadThunkError_UnrecognizedPaths $ (dir </>) <$> fs
@@ -244,71 +270,57 @@ matchThunkSpecToDir thunkSpec dir dirFiles = do
244270 case nonEmpty (toList $ requiredPaths `Set.difference` dirFiles) of
245271 Just fs -> throwError $ ReadThunkError_MissingPaths $ (dir </>) <$> fs
246272 Nothing -> pure ()
247− datas <- fmap toList $ flip Map.traverseMaybeWithKey (_thunkSpec_files thunkSpec) $ \expectedPath -> \case
248− ThunkFileSpec_AttrCache -> Nothing <$ dirMayExist expectedPath
249− ThunkFileSpec_CheckoutIndicator -> liftIO (doesDirectoryExist (dir </> expectedPath)) <&> \case
250− False -> Nothing
251− True -> Just ThunkData_Checkout
273+ ptrs <- fmap toList $ flip Map.traverseMaybeWithKey (_thunkSpec_files thunkSpec) $ \expectedPath -> \case
274+ ThunkFileSpec_FileMayExist -> liftIO (doesDirectoryExist (dir </> expectedPath)) >>= \case
275+ True -> throwError $ ReadThunkError_UnrecognizedPaths $ expectedPath :| []
276+ False -> pure Nothing
277+ ThunkFileSpec_DirMayExist -> dirMayExist expectedPath
278+ ThunkFileSpec_AttrCache -> dirMayExist expectedPath
252279 ThunkFileSpec_FileMatches expectedContents -> handle (\(e :: IOError) -> throwError $ ReadThunkError_FileError e) $ do
253280 actualContents <- liftIO (T.readFile $ dir </> expectedPath)
254281 case T.strip expectedContents == T.strip actualContents of
255282 True -> pure Nothing
256283 False -> throwError $ ReadThunkError_FileDoesNotMatch (dir </> expectedPath) expectedContents
257284 ThunkFileSpec_Ptr parser -> handle (\(e :: IOError) -> throwError $ ReadThunkError_FileError e) $ do
258− let path = dir </> expectedPath
259− liftIO (doesFileExist path) >>= \case
260− False -> pure Nothing
261− True -> do
262− actualContents <- liftIO $ LBS.readFile path
263− case parser actualContents of
264− Right v -> pure $ Just (ThunkData_Packed thunkSpec v)
265− Left e -> throwError $ ReadThunkError_UnparseablePtr (dir </> expectedPath) e
266−
267− case nonEmpty datas of
268− Nothing -> throwError ReadThunkError_UnrecognizedThunk
269− Just xs -> fold1WithM xs $ \a b -> either throwError pure (mergeThunkData a b)
270− where
271− rootPathsOnly = Set.fromList . mapMaybe takeRootDir . Map.keys
272− takeRootDir = fmap NonEmpty.head . nonEmpty . splitPath
285+ actualContents <- liftIO $ LBS.readFile $ dir </> expectedPath
286+ case parser actualContents of
287+ Right v -> pure $ Just v
288+ Left e -> throwError $ ReadThunkError_UnparseablePtr (dir </> expectedPath) e
273289
274− expectedPaths = rootPathsOnly $ _thunkSpec_files thunkSpec
290+ case nubOrd ptrs of
291+ [x] -> pure x
292+ _ -> throwError ReadThunkError_UnrecognizedThunk
275293
276− requiredPaths = rootPathsOnly $ Map.filter isRequiredFileSpec $ _thunkSpec_files thunkSpec
294+ where
295+ expectedPaths = Map.keysSet $ _thunkSpec_files thunkSpec
296+ requiredPaths = Map.keysSet $ Map.filter isRequiredFileSpec $ _thunkSpec_files thunkSpec
277297 isRequiredFileSpec = \case
278298 ThunkFileSpec_FileMatches _ -> True
299+ ThunkFileSpec_Ptr _ -> True
279300 _ -> False
280301
281302 dirMayExist expectedPath = liftIO (doesFileExist (dir </> expectedPath)) >>= \case
282303 True -> throwError $ ReadThunkError_UnrecognizedPaths $ expectedPath :| []
283− False -> pure ()
284−
285− -- Combine 'ThunkData' from different files, preferring "Checkout" over "Packed"
286− mergeThunkData ThunkData_Checkout ThunkData_Checkout = Right ThunkData_Checkout
287− mergeThunkData ThunkData_Checkout ThunkData_Packed{} = Left bothPackedAndUnpacked
288− mergeThunkData ThunkData_Packed{} ThunkData_Checkout = Left bothPackedAndUnpacked
289− mergeThunkData a@(ThunkData_Packed _ ptrA) (ThunkData_Packed _ ptrB) =
290− if ptrA == ptrB then Right a else Left $ ReadThunkError_AmbiguousPackedState ptrA ptrB
304+ False -> pure Nothing
291305
292− bothPackedAndUnpacked = ReadThunkError_UnrecognizedState "Both packed data and checkout present"
293−
294− fold1WithM (x :| xs) f = foldM f x xs
295−
296−readThunkWith
306+readPackedThunkWith
297307 :: (MonadObelisk m)
298− => NonEmpty (NonEmpty ThunkSpec) -> FilePath -> m (Either ReadThunkError ThunkData)
299−readThunkWith specTypes dir = do
308+ => NonEmpty (NonEmpty ThunkSpec) -> FilePath -> m (Either ReadThunkError (ThunkSpec, ThunkPtr))
309+readPackedThunkWith specTypes dir = do
300310 dirFiles <- Set.fromList <$> liftIO (listDirectory dir)
301311 let specs = concatMap toList $ toList $ NonEmpty.transpose specTypes -- Interleave spec types so we try each one in a "fair" ordering
302312 flip fix specs $ \loop -> \case
303313 [] -> pure $ Left ReadThunkError_UnrecognizedThunk
304314 spec:rest -> runExceptT (matchThunkSpecToDir spec dir dirFiles) >>= \case
305− Left e -> putLog Debug [i|Thunk specification ${_thunkSpec_name spec} did not match ${dir}: ${e}|] *> loop rest
306− x@(Right _) -> x <$ putLog Debug [i|Thunk specification ${_thunkSpec_name spec} matched ${dir}|]
315+ Left e -> do
316+ putLog Debug [i|Thunk ${_thunkSpec_name spec} specification did not match ${dir}: ${e}|]
317+ loop rest
318+ Right ptr -> Right (spec, ptr) <$ putLog Debug ("Thunk " <> _thunkSpec_name spec <> " matched " <> T.pack dir)
307319
308320-- | Read a thunk and validate that it is exactly a packed thunk.
309321-- If additional data is present, fail.
310−readThunk :: (MonadObelisk m) => FilePath -> m (Either ReadThunkError ThunkData)
311−readThunk = readThunkWith thunkSpecTypes
322+readPackedThunk :: (MonadObelisk m) => FilePath -> m (Either ReadThunkError (ThunkSpec, ThunkPtr))
323+readPackedThunk = readPackedThunkWith thunkSpecTypes
312324
313325parseThunkPtr :: (Aeson.Object -> Aeson.Parser ThunkSource) -> Aeson.Object -> Aeson.Parser ThunkPtr
314326parseThunkPtr parseSrc v = do
@@ -357,8 +369,8 @@ overwriteThunk target thunk = do
357369 Right _ -> pure ()
358370
359371 --TODO: Is there a safer way to do this overwriting?
360− liftIO $ removePathForcibly target
361− createThunk target $ Right thunk
372+ callProcessAndLogOutput (Debug, Error) $ proc rmPath ["-r", target] -- target may be a symlink
373+ createThunk target thunk
362374
363375thunkPtrToSpec :: ThunkPtr -> ThunkSpec
364376thunkPtrToSpec thunk = case _thunkPtr_source thunk of
@@ -410,16 +422,13 @@ encodeThunkPtrData (ThunkPtr rev src) = case src of
410422 , confTrailingNewline = True
411423 }
412424
413−createThunk :: MonadObelisk m => FilePath -> Either ThunkSpec ThunkPtr -> m ()
414−createThunk target ptrInfo =
415− ifor_ (_thunkSpec_files spec) $ \path -> \case
425+createThunk :: MonadObelisk m => FilePath -> ThunkPtr -> m ()
426+createThunk target ptr =
427+ ifor_ (_thunkSpec_files $ thunkPtrToSpec ptr) $ \path -> \case
416428 ThunkFileSpec_FileMatches content -> withReadyPath path $ \p -> liftIO $ T.writeFile p content
417− ThunkFileSpec_Ptr _ -> case ptrInfo of
418− Left _ -> pure () -- We can't write the ptr without it
419− Right ptr -> withReadyPath path $ \p -> liftIO $ LBS.writeFile p (encodeThunkPtrData ptr)
429+ ThunkFileSpec_Ptr _ -> withReadyPath path $ \p -> liftIO $ LBS.writeFile p (encodeThunkPtrData ptr)
420430 _ -> pure ()
421431 where
422− spec = either id thunkPtrToSpec ptrInfo
423432 withReadyPath path f = do
424433 let fullPath = target </> path
425434 putLog Debug $ "Writing thunk file " <> T.pack fullPath
@@ -429,22 +438,22 @@ createThunk target ptrInfo =
429438createThunkWithLatest :: MonadObelisk m => FilePath -> ThunkSource -> m ()
430439createThunkWithLatest target s = do
431440 rev <- getLatestRev s
432− createThunk target $ Right $ ThunkPtr
441+ createThunk target $ ThunkPtr
433442 { _thunkPtr_source = s
434443 , _thunkPtr_rev = rev
435444 }
436445
437446updateThunkToLatest :: MonadObelisk m => ThunkUpdateConfig -> FilePath -> m ()
438−updateThunkToLatest (ThunkUpdateConfig mBranch thunkConfig) target = spinner $ do
439− checkThunkDirectory target
447+updateThunkToLatest (ThunkUpdateConfig mBranch thunkConfig) target = withSpinner' ("Updating thunk " <> T.pack target <> " to latest") (pure $ const $ "Thunk " <> T.pack target <> " updated to latest") $ do
448+ checkThunkDirectory "ob thunk update directory cannot be '.'" target
440449 -- check to see if thunk should be updated to a specific branch or just update it's current branch
441450 case mBranch of
442451 Nothing -> do
443452 (overwrite, ptr) <- readThunk target >>= \case
444− Left err -> failWith [i|Thunk update: ${err}|]
453+ Left err -> failWith $ T.pack $ "thunk update: " <> show err
445454 Right c -> case c of
446− ThunkData_Packed _ t -> return (target, t)
447− ThunkData_Checkout -> failWith "cannot update an unpacked thunk"
455+ ThunkData_Packed (_, t) -> return (target, t)
456+ ThunkData_Checkout _ -> failWith "cannot update an unpacked thunk"
448457 let src = _thunkPtr_source ptr
449458 rev <- getLatestRev src
450459 overwriteThunk overwrite $ modifyThunkPtrByConfig thunkConfig $ ThunkPtr
@@ -452,12 +461,14 @@ updateThunkToLatest (ThunkUpdateConfig mBranch thunkConfig) target = spinner $ d
452461 , _thunkPtr_rev = rev
453462 }
454463 Just branch -> readThunk target >>= \case
455− Left err -> failWith [i|Thunk update: ${err}|]
464+ Left err -> failWith $ T.pack $ "thunk update: " <> show err
456465 Right c -> case c of
457− ThunkData_Packed _ t -> setThunk thunkConfig target (thunkSourceToGitSource $ _thunkPtr_source t) branch
458− ThunkData_Checkout -> failWith [i|Thunk located at ${target} is unpacked. Use 'ob thunk pack' on the desired directory and then try 'ob thunk update' again.|]
459− where
460− spinner = withSpinner' ("Updating thunk " <> T.pack target <> " to latest") (pure $ const $ "Thunk " <> T.pack target <> " updated to latest")
466+ ThunkData_Packed (_, t) -> case _thunkPtr_source t of
467+ ThunkSource_Git tsg -> setThunk thunkConfig target tsg branch
468+ ThunkSource_GitHub tsgh -> do
469+ let tsg = forgetGithub False tsgh
470+ setThunk thunkConfig target tsg branch
471+ ThunkData_Checkout _ -> failWith $ T.pack $ "thunk located at " <> show target <> " is unpacked. Use ob thunk pack on the desired directory and then try ob thunk update again."
461472
462473setThunk :: MonadObelisk m => ThunkConfig -> FilePath -> GitSource -> String -> m ()
463474setThunk thunkConfig target gs branch = do
@@ -528,7 +539,6 @@ legacyGitHubThunkSpec name loader = ThunkSpec name $ Map.fromList
528539 [ ("default.nix", ThunkFileSpec_FileMatches $ T.strip loader)
529540 , ("github.json" , ThunkFileSpec_Ptr parseGitHubJsonBytes)
530541 , (attrCacheFileName, ThunkFileSpec_AttrCache)
531− , (".git", ThunkFileSpec_CheckoutIndicator)
532542 ]
533543
534544gitHubThunkSpecV5 :: ThunkSpec
@@ -540,8 +550,7 @@ let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256
540550 } else (import <nixpkgs> {}).fetchFromGitHub {
541551 inherit owner repo rev sha256 fetchSubmodules private;
542552 };
543− json = builtins.fromJSON (builtins.readFile ./github.json);
544−in fetch json
553+in if builtins.pathExists ./_ then ./_ else fetch (builtins.fromJSON (builtins.readFile ./github.json))
545554|]
546555
547556parseGitHubJsonBytes :: LBS.ByteString -> Either String ThunkPtr
@@ -615,7 +624,6 @@ legacyGitThunkSpec name loader = ThunkSpec name $ Map.fromList
615624 [ ("default.nix", ThunkFileSpec_FileMatches $ T.strip loader)
616625 , ("git.json" , ThunkFileSpec_Ptr parseGitJsonBytes)
617626 , (attrCacheFileName, ThunkFileSpec_AttrCache)
618− , (".git", ThunkFileSpec_CheckoutIndicator)
619627 ]
620628
621629gitThunkSpecV5 :: ThunkSpec
@@ -632,8 +640,7 @@ let fetch = {url, rev, branch ? null, sha256 ? null, fetchSubmodules ? false, pr
632640 } else (import <nixpkgs> {}).fetchgit {
633641 url = realUrl; inherit rev sha256;
634642 };
635− json = builtins.fromJSON (builtins.readFile ./git.json);
636−in fetch json
643+in if builtins.pathExists ./_ then ./_ else fetch (builtins.fromJSON (builtins.readFile ./git.json))
637644|]
638645
639646parseGitJsonBytes :: LBS.ByteString -> Either String ThunkPtr
@@ -642,15 +649,14 @@ parseGitJsonBytes = parseJsonObject $ parseThunkPtr $ fmap ThunkSource_Git . par
642649mkThunkSpec :: Text -> FilePath -> (LBS.ByteString -> Either String ThunkPtr) -> Text -> ThunkSpec
643650mkThunkSpec name jsonFileName parser srcNix = ThunkSpec name $ Map.fromList
644651 [ ("default.nix", ThunkFileSpec_FileMatches defaultNixViaSrc)
645− , ("thunk.nix", ThunkFileSpec_FileMatches srcNix)
652+ , ("src.nix", ThunkFileSpec_FileMatches srcNix)
646653 , (jsonFileName, ThunkFileSpec_Ptr parser)
647654 , (attrCacheFileName, ThunkFileSpec_AttrCache)
648− , (normalise $ unpackedDirName </> ".git", ThunkFileSpec_CheckoutIndicator)
649655 ]
650656 where
651657 defaultNixViaSrc = [here|
652658# DO NOT HAND-EDIT THIS FILE
653−import (import ./thunk.nix)
659+import (import ./src.nix)
654660|]
655661
656662
@@ -685,7 +691,7 @@ nixBuildThunkAttrWithCache thunkSpec thunkDir attr = do
685691 for cachePaths' $ \cachePaths ->
686692 fmap NonEmpty.head $ for cachePaths $ \cacheDir -> do
687693 let
688− cachePath = thunkDir </> cacheDir </> attr <.> "out"
694+ cachePath = cacheDir </> attr <.> "out"
689695 cacheErrHandler e
690696 | isDoesNotExistError e = pure Nothing -- expected from a cache miss
691697 | otherwise = Nothing <$ putLog Error (T.pack $ displayException e)
@@ -718,7 +724,7 @@ nixBuildAttrWithCache
718724 -- ^ Symlink to cached or built nix output
719725nixBuildAttrWithCache exprPath attr = readThunk exprPath >>= \case
720726 -- Only packed thunks are cached. In particular, checkouts are not.
721− Right (ThunkData_Packed spec _) ->
727+ Right (ThunkData_Packed (spec, _)) ->
722728 maybe build pure =<< nixBuildThunkAttrWithCache spec exprPath attr
723729 _ -> build
724730 where
@@ -745,7 +751,7 @@ updateThunk p f = withSystemTempDirectory "obelisk-thunkptr-" $ \tmpDir -> do
745751 where
746752 copyThunkToTmp tmpDir thunkDir = readThunk thunkDir >>= \case
747753 Left err -> failWith $ "withThunkUnpacked: " <> T.pack (show err)
748− Right ThunkData_Packed{} -> do
754+ Right (ThunkData_Packed _) -> do
749755 let tmpThunk = tmpDir </> "thunk"
750756 callProcessAndLogOutput (Notice, Error) $
751757 proc cp ["-r", "-T", thunkDir, tmpThunk]
@@ -759,81 +765,58 @@ updateThunk p f = withSystemTempDirectory "obelisk-thunkptr-" $ \tmpDir -> do
759765finalMsg :: Bool -> (a -> Text) -> Maybe (a -> Text)
760766finalMsg noTrail s = if noTrail then Nothing else Just s
761767
768+unpackThunk :: MonadObelisk m => FilePath -> m ()
769+unpackThunk = unpackThunk' False
770+
762771-- | Check that we are not somewhere inside the thunk directory
763−checkThunkDirectory :: MonadObelisk m => FilePath -> m ()
764−checkThunkDirectory thunkDir = do
772+checkThunkDirectory :: MonadObelisk m => Text -> FilePath -> m ()
773+checkThunkDirectory msg thunkDir = do
765774 currentDir <- liftIO getCurrentDirectory
766775 thunkDir' <- liftIO $ canonicalizePath thunkDir
767− when (thunkDir' `L.isInfixOf` currentDir) $
768− failWith [i|Can't perform thunk operations from within the thunk directory: ${thunkDir}|]
769−
770− -- Don't let thunk commands work when directly given an unpacked repo
771− when (takeFileName thunkDir == unpackedDirName) $
772− readThunk (takeDirectory thunkDir) >>= \case
773− Right _ -> failWith [i|Refusing to perform thunk operation on ${thunkDir} because it is a thunk's unpacked source|]
774− Left _ -> pure ()
775−
776−unpackThunk :: MonadObelisk m => FilePath -> m ()
777−unpackThunk = unpackThunk' False
776+ when (thunkDir' `L.isInfixOf` currentDir) $ failWith msg
778777
779778unpackThunk' :: MonadObelisk m => Bool -> FilePath -> m ()
780−unpackThunk' noTrail thunkDir = checkThunkDirectory thunkDir *> readThunk thunkDir >>= \case
779+unpackThunk' noTrail thunkDir = checkThunkDirectory "Can't pack/unpack from within the thunk directory" thunkDir >> readThunk thunkDir >>= \case
781780 Left err -> failWith [i|Invalid thunk at ${thunkDir}: ${err}|]
782781 --TODO: Overwrite option that rechecks out thunk; force option to do so even if working directory is dirty
783− Right ThunkData_Checkout -> failWith [i|Thunk at ${thunkDir} is already unpacked|]
784− Right (ThunkData_Packed _ tptr) -> do
782+ Right (ThunkData_Checkout _) -> failWith [i|Thunk at ${thunkDir} is already unpacked|]
783+ Right (ThunkData_Packed (_, tptr)) -> do
785784 let (thunkParent, thunkName) = splitFileName thunkDir
786− withTempDirectory thunkParent thunkName $ \tmpThunk -> do
785+ withTempDirectory thunkParent thunkName $ \tmpRepo -> do
787786 let
788− gitSrc = thunkSourceToGitSource $ _thunkPtr_source tptr
789− newSpec = case _thunkPtr_source tptr of
790− ThunkSource_GitHub _ -> NonEmpty.head gitHubThunkSpecs
791− ThunkSource_Git _ -> NonEmpty.head gitThunkSpecs
787+ s = case _thunkPtr_source tptr of
788+ ThunkSource_GitHub s' -> forgetGithub False s'
789+ ThunkSource_Git s' -> s'
792790 withSpinner' ("Fetching thunk " <> T.pack thunkName)
793791 (finalMsg noTrail $ const $ "Fetched thunk " <> T.pack thunkName) $ do
794− let unpackedPath = tmpThunk </> unpackedDirName
795− gitCloneForThunkUnpack gitSrc (_thunkRev_commit $ _thunkPtr_rev tptr) unpackedPath
796−
797− let normalizeMore = dropTrailingPathSeparator . normalise
798− when (normalizeMore unpackedPath /= normalizeMore tmpThunk) $ -- Only write meta data if the checkout is not inplace
799− createThunk tmpThunk $ Left newSpec
800−
801− liftIO $ do
802− removePathForcibly thunkDir
803− renameDirectory tmpThunk thunkDir
804−
805−gitCloneForThunkUnpack
806− :: MonadObelisk m
807− => GitSource -- ^ Git source to use
808− -> Ref hash -- ^ Commit hash to reset to
809− -> FilePath -- ^ Directory to clone into
810− -> m ()
811−gitCloneForThunkUnpack gitSrc commit dir = do
812− let git = callProcessAndLogOutput (Notice, Notice) . gitProc dir
813− git $ [ "clone" ]
814− ++ ["--recursive" | _gitSource_fetchSubmodules gitSrc]
815− ++ [ T.unpack $ gitUriToText $ _gitSource_url gitSrc ]
816− ++ do branch <- maybeToList $ _gitSource_branch gitSrc
817− [ "--branch", T.unpack $ untagName branch ]
818− git ["reset", "--hard", Ref.toHexString commit]
819− when (_gitSource_fetchSubmodules gitSrc) $
820− git ["submodule", "update", "--recursive", "--init"]
792+ let git = callProcessAndLogOutput (Notice, Notice) . gitProc tmpRepo
793+ git $ [ "clone" ]
794+ ++ ["--recursive" | _gitSource_fetchSubmodules s]
795+ ++ [ T.unpack $ gitUriToText $ _gitSource_url s ]
796+ ++ do branch <- maybeToList $ _gitSource_branch s
797+ [ "--branch", T.unpack $ untagName branch ]
798+ git ["reset", "--hard", Ref.toHexString $ _thunkRev_commit $ _thunkPtr_rev tptr]
799+ when (_gitSource_fetchSubmodules s) $
800+ git ["submodule", "update", "--recursive", "--init"]
801+
802+ let unpackedPath = thunkDir </> unpackedDirName
803+ liftIO $ createDirectoryIfMissing True (takeDirectory unpackedPath)
804+ callProcessAndLogOutput (Notice, Error) $ proc mvPath [tmpRepo, unpackedPath]
821805
822806--TODO: add a rollback mode to pack to the original thunk
823807packThunk :: MonadObelisk m => ThunkPackConfig -> FilePath -> m ThunkPtr
824808packThunk = packThunk' False
825809
826810packThunk' :: MonadObelisk m => Bool -> ThunkPackConfig -> FilePath -> m ThunkPtr
827−packThunk' noTrail (ThunkPackConfig force thunkConfig) thunkDir = checkThunkDirectory thunkDir *> readThunk thunkDir >>= \case
828− Right ThunkData_Packed{} -> failWith [i|Thunk at ${thunkDir} is is already packed|]
829− _ -> withSpinner'
830− ("Packing thunk " <> T.pack thunkDir)
831− (finalMsg noTrail $ const $ "Packed thunk " <> T.pack thunkDir) $
832− do
833− let checkClean = if force then CheckClean_NoCheck else CheckClean_FullCheck
834− thunkPtr <- modifyThunkPtrByConfig thunkConfig <$> getThunkPtr checkClean thunkDir (_thunkConfig_private thunkConfig)
835− liftIO $ removePathForcibly thunkDir
836− createThunk thunkDir $ Right thunkPtr
811+packThunk' noTrail (ThunkPackConfig force thunkConfig) thunkDir = checkThunkDirectory "Can't pack/unpack from within the thunk directory" thunkDir >> readThunk thunkDir >>= \case
812+ Left err -> failWith [i|Can't pack thunk at ${thunkDir}: ${err}|]
813+ Right (ThunkData_Packed _) -> failWith [i|Thunk at ${thunkDir} is is already packed|]
814+ Right (ThunkData_Checkout _) -> do
815+ withSpinner' ("Packing thunk " <> T.pack thunkDir)
816+ (finalMsg noTrail $ const $ "Packed thunk " <> T.pack thunkDir) $ do
817+ thunkPtr <- modifyThunkPtrByConfig thunkConfig <$> getThunkPtr (not force) thunkDir (_thunkConfig_private thunkConfig)
818+ callProcessAndLogOutput (Debug, Error) $ proc rmPath ["-rf", thunkDir] -- thunkDir may be a symlink
819+ createThunk thunkDir thunkPtr
837820 pure thunkPtr
838821
839822modifyThunkPtrByConfig :: ThunkConfig -> ThunkPtr -> ThunkPtr
@@ -844,38 +827,26 @@ modifyThunkPtrByConfig (ThunkConfig markPrivate') ptr = case markPrivate' of
844827 ThunkSource_GitHub s -> ThunkSource_GitHub $ s { _gitHubSource_private = markPrivate }
845828 }
846829
847−data CheckClean
848− = CheckClean_FullCheck
849− -- ^ Check that the repo is clean, including .gitignored files
850− | CheckClean_NotIgnored
851− -- ^ Check that the repo is clean, not including .gitignored files
852− | CheckClean_NoCheck
853− -- ^ Don't check that the repo is clean
854−
855−getThunkPtr :: forall m. MonadObelisk m => CheckClean -> FilePath -> Maybe Bool -> m ThunkPtr
856−getThunkPtr gitCheckClean dir mPrivate = do
857− let repoLocations = nubOrd $ map (first normalise)
858− [(".git", "."), (unpackedDirName </> ".git", unpackedDirName)]
830+getThunkPtr :: forall m. MonadObelisk m => Bool -> FilePath -> Maybe Bool -> m ThunkPtr
831+getThunkPtr checkClean dir mPrivate = do
832+ let repoLocations = [(".git", "."), (unpackedDirName, unpackedDirName)]
859833 repoLocation' <- liftIO $ flip findM repoLocations $ doesDirectoryExist . (dir </>) . fst
860834 thunkDir <- case repoLocation' of
861835 Nothing -> failWith [i|Can't find an unpacked thunk in ${dir}|]
862836 Just (_, path) -> pure $ normalise $ dir </> path
863837
864− let (checkClean, checkIgnored) = case gitCheckClean of
865− CheckClean_FullCheck -> (True, True)
866− CheckClean_NotIgnored -> (True, False)
867− CheckClean_NoCheck -> (False, False)
868− when checkClean $ ensureCleanGitRepo thunkDir checkIgnored
838+ when checkClean $ ensureCleanGitRepo thunkDir True
869839 "thunk pack: thunk checkout contains unsaved modifications"
870840
871841 -- Check whether there are any stashes
872− when checkClean $ do
873− stashOutput <- readGitProcess thunkDir ["stash", "list"]
874− unless (T.null stashOutput) $
842+ stashOutput <- readGitProcess thunkDir ["stash", "list"]
843+ when checkClean $ case T.null stashOutput of
844+ False -> do
875845 failWith $ T.unlines $
876846 [ "thunk pack: thunk checkout has stashes"
877847 , "git stash list:"
878848 ] ++ T.lines stashOutput
849+ True -> return ()
879850
880851 -- Get current branch
881852 (mCurrentBranch, mCurrentCommit) <- do
@@ -891,7 +862,7 @@ getThunkPtr gitCheckClean dir mPrivate = do
891862
892863 -- Get information on all branches and their (optional) designated upstream
893864 -- correspondents
894− headDump :: [Text] <- T.lines <$> readGitProcess thunkDir
865+ (headDump :: [Text]) <- T.lines <$> readGitProcess thunkDir
895866 [ "for-each-ref"
896867 , "--format=%(refname:short) %(upstream:short) %(upstream:remotename)"
897868 , "refs/heads/"
@@ -961,9 +932,8 @@ getThunkPtr gitCheckClean dir mPrivate = do
961932 \pushed but this repo's remote tracking branches don't know it.)"
962933 ]
963934
964− when checkClean $ do
965− -- We assume it's safe to pack the thunk at this point
966− putLog Informational "All changes safe in git remotes. OK to pack thunk."
935+ -- We assume it's safe to pack the thunk at this point
936+ putLog Informational "All changes safe in git remotes. OK to pack thunk."
967937
968938 let remote = maybe "origin" snd $ flip Map.lookup headUpstream =<< mCurrentBranch
969939
@@ -981,7 +951,9 @@ getThunkPtr gitCheckClean dir mPrivate = do
981951-- | Get the latest revision available from the given source
982952getLatestRev :: MonadObelisk m => ThunkSource -> m ThunkRev
983953getLatestRev os = do
984− let gitS = thunkSourceToGitSource os
954+ let gitS = case os of
955+ ThunkSource_GitHub s -> forgetGithub False s
956+ ThunkSource_Git s -> s
985957 (_, commit) <- gitGetCommitBranch (_gitSource_url gitS) (untagName <$> _gitSource_branch gitS)
986958 case os of
987959 ThunkSource_GitHub s -> githubThunkRev s commit