@@ -21,12 +21,14 @@ 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)
2425import qualified Data.ByteString.Lazy as LBS
2526import Data.Containers.ListUtils (nubOrd)
2627import Data.Default
2728import Data.Either.Combinators (fromRight', rightToMaybe)
2829import Data.Foldable (toList)
2930import Data.Function ((&))
31+import Data.Functor ((<&>))
3032import Data.Git.Ref (Ref)
3133import qualified Data.Git.Ref as Ref
3234import qualified Data.List as L
@@ -54,7 +56,7 @@ import System.Exit
5456import System.FilePath
5557import System.IO.Error
5658import System.IO.Temp
57−import System.Posix (getSymbolicLinkStatus, modificationTime)
59+import System.PosixCompat.Files (getSymbolicLinkStatus, modificationTime)
5860import qualified Text.URI as URI
5961
6062import Obelisk.App (MonadObelisk)
@@ -63,9 +65,9 @@ import Obelisk.Command.Utils
6365
6466--TODO: Support symlinked thunk data
6567data ThunkData
66− = ThunkData_Packed (ThunkSpec, ThunkPtr)
68+ = ThunkData_Packed ThunkSpec ThunkPtr
6769 -- ^ Packed thunk
68− | ThunkData_Checkout (Maybe (ThunkSpec, ThunkPtr))
70+ | ThunkData_Checkout
6971 -- ^ Checked out thunk that was unpacked from this pointer
7072
7173-- | A reference to the exact data that a thunk should translate into
@@ -92,6 +94,11 @@ data ThunkSource
9294 | ThunkSource_Git GitSource
9395 deriving (Show, Eq, Ord)
9496
97+thunkSourceToGitSource :: ThunkSource -> GitSource
98+thunkSourceToGitSource = \case
99+ ThunkSource_GitHub s -> forgetGithub False s
100+ ThunkSource_Git s -> s
101+
95102data GitHubSource = GitHubSource
96103 { _gitHubSource_owner :: Name Owner
97104 , _gitHubSource_repo :: Name Repo
@@ -171,14 +178,14 @@ getNixSha256ForUriUnpacked
171178getNixSha256ForUriUnpacked uri =
172179 withExitFailMessage ("nix-prefetch-url: Failed to determine sha256 hash of URL " <> gitUriToText uri) $ do
173180 [hash] <- fmap T.lines $ readProcessAndLogOutput (Debug, Debug) $
174− proc "nix-prefetch-url" ["--unpack", "--type", "sha256", T.unpack $ gitUriToText uri]
181+ proc nixPrefetchUrlPath ["--unpack", "--type", "sha256", T.unpack $ gitUriToText uri]
175182 pure hash
176183
177184nixPrefetchGit :: MonadObelisk m => GitUri -> Text -> Bool -> m NixSha256
178185nixPrefetchGit uri rev fetchSubmodules =
179186 withExitFailMessage ("nix-prefetch-git: Failed to determine sha256 hash of Git repo " <> gitUriToText uri <> " at " <> rev) $ do
180187 out <- readProcessAndLogStderr Debug $
181− proc "nix-prefetch-git" $ filter (/="")
188+ proc nixPrefetchGitPath $ filter (/="")
182189 [ "--url", T.unpack $ gitUriToText uri
183190 , "--rev", T.unpack rev
184191 , if fetchSubmodules then "--fetch-submodules" else ""
@@ -191,61 +198,28 @@ nixPrefetchGit uri rev fetchSubmodules =
191198
192199--TODO: Pretty print these
193200data ReadThunkError
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
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)
235210
236211unpackedDirName :: FilePath
237−unpackedDirName = "_"
212+unpackedDirName = "."
238213
239214attrCacheFileName :: FilePath
240215attrCacheFileName = ".attr-cache"
241216
242217-- | Specification for how a file in a thunk version works.
243218data ThunkFileSpec
244− = ThunkFileSpec_FileMayExist
245− | ThunkFileSpec_DirMayExist
246− | ThunkFileSpec_AttrCache
247− | ThunkFileSpec_Ptr (LBS.ByteString -> Either String ThunkPtr)
248− | ThunkFileSpec_FileMatches Text
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
249223
250224-- | Specification for how a set of files in a thunk version work.
251225data ThunkSpec = ThunkSpec
@@ -262,7 +236,7 @@ matchThunkSpecToDir
262236 => ThunkSpec -- ^ 'ThunkSpec' to match against the given files/directory
263237 -> FilePath -- ^ Path to directory
264238 -> Set FilePath -- ^ Set of file paths relative to the given directory
265− -> m ThunkPtr
239+ -> m ThunkData
266240matchThunkSpecToDir thunkSpec dir dirFiles = do
267241 case nonEmpty (toList $ dirFiles `Set.difference` expectedPaths) of
268242 Just fs -> throwError $ ReadThunkError_UnrecognizedPaths $ (dir </>) <$> fs
@@ -270,57 +244,71 @@ matchThunkSpecToDir thunkSpec dir dirFiles = do
270244 case nonEmpty (toList $ requiredPaths `Set.difference` dirFiles) of
271245 Just fs -> throwError $ ReadThunkError_MissingPaths $ (dir </>) <$> fs
272246 Nothing -> pure ()
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
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
279252 ThunkFileSpec_FileMatches expectedContents -> handle (\(e :: IOError) -> throwError $ ReadThunkError_FileError e) $ do
280253 actualContents <- liftIO (T.readFile $ dir </> expectedPath)
281254 case T.strip expectedContents == T.strip actualContents of
282255 True -> pure Nothing
283256 False -> throwError $ ReadThunkError_FileDoesNotMatch (dir </> expectedPath) expectedContents
284257 ThunkFileSpec_Ptr parser -> handle (\(e :: IOError) -> throwError $ ReadThunkError_FileError e) $ do
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
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
289273
290− case nubOrd ptrs of
291− [x] -> pure x
292− _ -> throwError ReadThunkError_UnrecognizedThunk
274+ expectedPaths = rootPathsOnly $ _thunkSpec_files thunkSpec
293275
294− where
295− expectedPaths = Map.keysSet $ _thunkSpec_files thunkSpec
296− requiredPaths = Map.keysSet $ Map.filter isRequiredFileSpec $ _thunkSpec_files thunkSpec
276+ requiredPaths = rootPathsOnly $ Map.filter isRequiredFileSpec $ _thunkSpec_files thunkSpec
297277 isRequiredFileSpec = \case
298278 ThunkFileSpec_FileMatches _ -> True
299− ThunkFileSpec_Ptr _ -> True
300279 _ -> False
301280
302281 dirMayExist expectedPath = liftIO (doesFileExist (dir </> expectedPath)) >>= \case
303282 True -> throwError $ ReadThunkError_UnrecognizedPaths $ expectedPath :| []
304− False -> pure Nothing
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
305291
306−readPackedThunkWith
292+ bothPackedAndUnpacked = ReadThunkError_UnrecognizedState "Both packed data and checkout present"
293+
294+ fold1WithM (x :| xs) f = foldM f x xs
295+
296+readThunkWith
307297 :: (MonadObelisk m)
308− => NonEmpty (NonEmpty ThunkSpec) -> FilePath -> m (Either ReadThunkError (ThunkSpec, ThunkPtr))
309−readPackedThunkWith specTypes dir = do
298+ => NonEmpty (NonEmpty ThunkSpec) -> FilePath -> m (Either ReadThunkError ThunkData)
299+readThunkWith specTypes dir = do
310300 dirFiles <- Set.fromList <$> liftIO (listDirectory dir)
311301 let specs = concatMap toList $ toList $ NonEmpty.transpose specTypes -- Interleave spec types so we try each one in a "fair" ordering
312302 flip fix specs $ \loop -> \case
313303 [] -> pure $ Left ReadThunkError_UnrecognizedThunk
314304 spec:rest -> runExceptT (matchThunkSpecToDir spec dir dirFiles) >>= \case
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)
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}|]
319307
320308-- | Read a thunk and validate that it is exactly a packed thunk.
321309-- If additional data is present, fail.
322−readPackedThunk :: (MonadObelisk m) => FilePath -> m (Either ReadThunkError (ThunkSpec, ThunkPtr))
323−readPackedThunk = readPackedThunkWith thunkSpecTypes
310+readThunk :: (MonadObelisk m) => FilePath -> m (Either ReadThunkError ThunkData)
311+readThunk = readThunkWith thunkSpecTypes
324312
325313parseThunkPtr :: (Aeson.Object -> Aeson.Parser ThunkSource) -> Aeson.Object -> Aeson.Parser ThunkPtr
326314parseThunkPtr parseSrc v = do
@@ -369,8 +357,8 @@ overwriteThunk target thunk = do
369357 Right _ -> pure ()
370358
371359 --TODO: Is there a safer way to do this overwriting?
372− callProcessAndLogOutput (Debug, Error) $ proc rmPath ["-r", target] -- target may be a symlink
373− createThunk target thunk
360+ liftIO $ removePathForcibly target
361+ createThunk target $ Right thunk
374362
375363thunkPtrToSpec :: ThunkPtr -> ThunkSpec
376364thunkPtrToSpec thunk = case _thunkPtr_source thunk of
@@ -422,13 +410,16 @@ encodeThunkPtrData (ThunkPtr rev src) = case src of
422410 , confTrailingNewline = True
423411 }
424412
425−createThunk :: MonadObelisk m => FilePath -> ThunkPtr -> m ()
426−createThunk target ptr =
427− ifor_ (_thunkSpec_files $ thunkPtrToSpec ptr) $ \path -> \case
413+createThunk :: MonadObelisk m => FilePath -> Either ThunkSpec ThunkPtr -> m ()
414+createThunk target ptrInfo =
415+ ifor_ (_thunkSpec_files spec) $ \path -> \case
428416 ThunkFileSpec_FileMatches content -> withReadyPath path $ \p -> liftIO $ T.writeFile p content
429− ThunkFileSpec_Ptr _ -> withReadyPath path $ \p -> liftIO $ LBS.writeFile p (encodeThunkPtrData ptr)
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)
430420 _ -> pure ()
431421 where
422+ spec = either id thunkPtrToSpec ptrInfo
432423 withReadyPath path f = do
433424 let fullPath = target </> path
434425 putLog Debug $ "Writing thunk file " <> T.pack fullPath
@@ -438,22 +429,22 @@ createThunk target ptr =
438429createThunkWithLatest :: MonadObelisk m => FilePath -> ThunkSource -> m ()
439430createThunkWithLatest target s = do
440431 rev <- getLatestRev s
441− createThunk target $ ThunkPtr
432+ createThunk target $ Right $ ThunkPtr
442433 { _thunkPtr_source = s
443434 , _thunkPtr_rev = rev
444435 }
445436
446437updateThunkToLatest :: MonadObelisk m => ThunkUpdateConfig -> FilePath -> m ()
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
438+updateThunkToLatest (ThunkUpdateConfig mBranch thunkConfig) target = spinner $ do
439+ checkThunkDirectory target
449440 -- check to see if thunk should be updated to a specific branch or just update it's current branch
450441 case mBranch of
451442 Nothing -> do
452443 (overwrite, ptr) <- readThunk target >>= \case
453− Left err -> failWith $ T.pack $ "thunk update: " <> show err
444+ Left err -> failWith [i|Thunk update: ${err}|]
454445 Right c -> case c of
455− ThunkData_Packed (_, t) -> return (target, t)
456− ThunkData_Checkout _ -> failWith "cannot update an unpacked thunk"
446+ ThunkData_Packed _ t -> return (target, t)
447+ ThunkData_Checkout -> failWith "cannot update an unpacked thunk"
457448 let src = _thunkPtr_source ptr
458449 rev <- getLatestRev src
459450 overwriteThunk overwrite $ modifyThunkPtrByConfig thunkConfig $ ThunkPtr
@@ -461,14 +452,12 @@ updateThunkToLatest (ThunkUpdateConfig mBranch thunkConfig) target = withSpinner
461452 , _thunkPtr_rev = rev
462453 }
463454 Just branch -> readThunk target >>= \case
464− Left err -> failWith $ T.pack $ "thunk update: " <> show err
455+ Left err -> failWith [i|Thunk update: ${err}|]
465456 Right c -> case c of
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."
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")
472461
473462setThunk :: MonadObelisk m => ThunkConfig -> FilePath -> GitSource -> String -> m ()
474463setThunk thunkConfig target gs branch = do
@@ -539,6 +528,7 @@ legacyGitHubThunkSpec name loader = ThunkSpec name $ Map.fromList
539528 [ ("default.nix", ThunkFileSpec_FileMatches $ T.strip loader)
540529 , ("github.json" , ThunkFileSpec_Ptr parseGitHubJsonBytes)
541530 , (attrCacheFileName, ThunkFileSpec_AttrCache)
531+ , (".git", ThunkFileSpec_CheckoutIndicator)
542532 ]
543533
544534gitHubThunkSpecV5 :: ThunkSpec
@@ -550,7 +540,8 @@ let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256
550540 } else (import <nixpkgs> {}).fetchFromGitHub {
551541 inherit owner repo rev sha256 fetchSubmodules private;
552542 };
553−in if builtins.pathExists ./_ then ./_ else fetch (builtins.fromJSON (builtins.readFile ./github.json))
543+ json = builtins.fromJSON (builtins.readFile ./github.json);
544+in fetch json
554545|]
555546
556547parseGitHubJsonBytes :: LBS.ByteString -> Either String ThunkPtr
@@ -624,6 +615,7 @@ legacyGitThunkSpec name loader = ThunkSpec name $ Map.fromList
624615 [ ("default.nix", ThunkFileSpec_FileMatches $ T.strip loader)
625616 , ("git.json" , ThunkFileSpec_Ptr parseGitJsonBytes)
626617 , (attrCacheFileName, ThunkFileSpec_AttrCache)
618+ , (".git", ThunkFileSpec_CheckoutIndicator)
627619 ]
628620
629621gitThunkSpecV5 :: ThunkSpec
@@ -640,7 +632,8 @@ let fetch = {url, rev, branch ? null, sha256 ? null, fetchSubmodules ? false, pr
640632 } else (import <nixpkgs> {}).fetchgit {
641633 url = realUrl; inherit rev sha256;
642634 };
643−in if builtins.pathExists ./_ then ./_ else fetch (builtins.fromJSON (builtins.readFile ./git.json))
635+ json = builtins.fromJSON (builtins.readFile ./git.json);
636+in fetch json
644637|]
645638
646639parseGitJsonBytes :: LBS.ByteString -> Either String ThunkPtr
@@ -649,14 +642,15 @@ parseGitJsonBytes = parseJsonObject $ parseThunkPtr $ fmap ThunkSource_Git . par
649642mkThunkSpec :: Text -> FilePath -> (LBS.ByteString -> Either String ThunkPtr) -> Text -> ThunkSpec
650643mkThunkSpec name jsonFileName parser srcNix = ThunkSpec name $ Map.fromList
651644 [ ("default.nix", ThunkFileSpec_FileMatches defaultNixViaSrc)
652− , ("src.nix", ThunkFileSpec_FileMatches srcNix)
645+ , ("thunk.nix", ThunkFileSpec_FileMatches srcNix)
653646 , (jsonFileName, ThunkFileSpec_Ptr parser)
654647 , (attrCacheFileName, ThunkFileSpec_AttrCache)
648+ , (normalise $ unpackedDirName </> ".git", ThunkFileSpec_CheckoutIndicator)
655649 ]
656650 where
657651 defaultNixViaSrc = [here|
658652# DO NOT HAND-EDIT THIS FILE
659−import (import ./src.nix)
653+import (import ./thunk.nix)
660654|]
661655
662656
@@ -691,7 +685,7 @@ nixBuildThunkAttrWithCache thunkSpec thunkDir attr = do
691685 for cachePaths' $ \cachePaths ->
692686 fmap NonEmpty.head $ for cachePaths $ \cacheDir -> do
693687 let
694− cachePath = cacheDir </> attr <.> "out"
688+ cachePath = thunkDir </> cacheDir </> attr <.> "out"
695689 cacheErrHandler e
696690 | isDoesNotExistError e = pure Nothing -- expected from a cache miss
697691 | otherwise = Nothing <$ putLog Error (T.pack $ displayException e)
@@ -724,7 +718,7 @@ nixBuildAttrWithCache
724718 -- ^ Symlink to cached or built nix output
725719nixBuildAttrWithCache exprPath attr = readThunk exprPath >>= \case
726720 -- Only packed thunks are cached. In particular, checkouts are not.
727− Right (ThunkData_Packed (spec, _)) ->
721+ Right (ThunkData_Packed spec _) ->
728722 maybe build pure =<< nixBuildThunkAttrWithCache spec exprPath attr
729723 _ -> build
730724 where
@@ -751,7 +745,7 @@ updateThunk p f = withSystemTempDirectory "obelisk-thunkptr-" $ \tmpDir -> do
751745 where
752746 copyThunkToTmp tmpDir thunkDir = readThunk thunkDir >>= \case
753747 Left err -> failWith $ "withThunkUnpacked: " <> T.pack (show err)
754− Right (ThunkData_Packed _) -> do
748+ Right ThunkData_Packed{} -> do
755749 let tmpThunk = tmpDir </> "thunk"
756750 callProcessAndLogOutput (Notice, Error) $
757751 proc cp ["-r", "-T", thunkDir, tmpThunk]
@@ -765,58 +759,81 @@ updateThunk p f = withSystemTempDirectory "obelisk-thunkptr-" $ \tmpDir -> do
765759finalMsg :: Bool -> (a -> Text) -> Maybe (a -> Text)
766760finalMsg noTrail s = if noTrail then Nothing else Just s
767761
768−unpackThunk :: MonadObelisk m => FilePath -> m ()
769−unpackThunk = unpackThunk' False
770−
771762-- | Check that we are not somewhere inside the thunk directory
772−checkThunkDirectory :: MonadObelisk m => Text -> FilePath -> m ()
773−checkThunkDirectory msg thunkDir = do
763+checkThunkDirectory :: MonadObelisk m => FilePath -> m ()
764+checkThunkDirectory thunkDir = do
774765 currentDir <- liftIO getCurrentDirectory
775766 thunkDir' <- liftIO $ canonicalizePath thunkDir
776− when (thunkDir' `L.isInfixOf` currentDir) $ failWith msg
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
777778
778779unpackThunk' :: MonadObelisk m => Bool -> FilePath -> m ()
779−unpackThunk' noTrail thunkDir = checkThunkDirectory "Can't pack/unpack from within the thunk directory" thunkDir >> readThunk thunkDir >>= \case
780+unpackThunk' noTrail thunkDir = checkThunkDirectory thunkDir *> readThunk thunkDir >>= \case
780781 Left err -> failWith [i|Invalid thunk at ${thunkDir}: ${err}|]
781782 --TODO: Overwrite option that rechecks out thunk; force option to do so even if working directory is dirty
782− Right (ThunkData_Checkout _) -> failWith [i|Thunk at ${thunkDir} is already unpacked|]
783− Right (ThunkData_Packed (_, tptr)) -> do
783+ Right ThunkData_Checkout -> failWith [i|Thunk at ${thunkDir} is already unpacked|]
784+ Right (ThunkData_Packed _ tptr) -> do
784785 let (thunkParent, thunkName) = splitFileName thunkDir
785− withTempDirectory thunkParent thunkName $ \tmpRepo -> do
786+ withTempDirectory thunkParent thunkName $ \tmpThunk -> do
786787 let
787− s = case _thunkPtr_source tptr of
788− ThunkSource_GitHub s' -> forgetGithub False s'
789− ThunkSource_Git s' -> s'
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
790792 withSpinner' ("Fetching thunk " <> T.pack thunkName)
791793 (finalMsg noTrail $ const $ "Fetched thunk " <> T.pack thunkName) $ do
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]
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"]
805821
806822--TODO: add a rollback mode to pack to the original thunk
807823packThunk :: MonadObelisk m => ThunkPackConfig -> FilePath -> m ThunkPtr
808824packThunk = packThunk' False
809825
810826packThunk' :: MonadObelisk m => Bool -> ThunkPackConfig -> FilePath -> m 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
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
820837 pure thunkPtr
821838
822839modifyThunkPtrByConfig :: ThunkConfig -> ThunkPtr -> ThunkPtr
@@ -827,26 +844,38 @@ modifyThunkPtrByConfig (ThunkConfig markPrivate') ptr = case markPrivate' of
827844 ThunkSource_GitHub s -> ThunkSource_GitHub $ s { _gitHubSource_private = markPrivate }
828845 }
829846
830−getThunkPtr :: forall m. MonadObelisk m => Bool -> FilePath -> Maybe Bool -> m ThunkPtr
831−getThunkPtr checkClean dir mPrivate = do
832− let repoLocations = [(".git", "."), (unpackedDirName, unpackedDirName)]
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)]
833859 repoLocation' <- liftIO $ flip findM repoLocations $ doesDirectoryExist . (dir </>) . fst
834860 thunkDir <- case repoLocation' of
835861 Nothing -> failWith [i|Can't find an unpacked thunk in ${dir}|]
836862 Just (_, path) -> pure $ normalise $ dir </> path
837863
838− when checkClean $ ensureCleanGitRepo thunkDir True
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
839869 "thunk pack: thunk checkout contains unsaved modifications"
840870
841871 -- Check whether there are any stashes
842− stashOutput <- readGitProcess thunkDir ["stash", "list"]
843− when checkClean $ case T.null stashOutput of
844− False -> do
872+ when checkClean $ do
873+ stashOutput <- readGitProcess thunkDir ["stash", "list"]
874+ unless (T.null stashOutput) $
845875 failWith $ T.unlines $
846876 [ "thunk pack: thunk checkout has stashes"
847877 , "git stash list:"
848878 ] ++ T.lines stashOutput
849− True -> return ()
850879
851880 -- Get current branch
852881 (mCurrentBranch, mCurrentCommit) <- do
@@ -862,7 +891,7 @@ getThunkPtr checkClean dir mPrivate = do
862891
863892 -- Get information on all branches and their (optional) designated upstream
864893 -- correspondents
865− (headDump :: [Text]) <- T.lines <$> readGitProcess thunkDir
894+ headDump :: [Text] <- T.lines <$> readGitProcess thunkDir
866895 [ "for-each-ref"
867896 , "--format=%(refname:short) %(upstream:short) %(upstream:remotename)"
868897 , "refs/heads/"
@@ -932,8 +961,9 @@ getThunkPtr checkClean dir mPrivate = do
932961 \pushed but this repo's remote tracking branches don't know it.)"
933962 ]
934963
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."
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."
937967
938968 let remote = maybe "origin" snd $ flip Map.lookup headUpstream =<< mCurrentBranch
939969
@@ -951,9 +981,7 @@ getThunkPtr checkClean dir mPrivate = do
951981-- | Get the latest revision available from the given source
952982getLatestRev :: MonadObelisk m => ThunkSource -> m ThunkRev
953983getLatestRev os = do
954− let gitS = case os of
955− ThunkSource_GitHub s -> forgetGithub False s
956− ThunkSource_Git s -> s
984+ let gitS = thunkSourceToGitSource os
957985 (_, commit) <- gitGetCommitBranch (_gitSource_url gitS) (untagName <$> _gitSource_branch gitS)
958986 case os of
959987 ThunkSource_GitHub s -> githubThunkRev s commit