@@ -14,13 +14,14 @@ import Control.Applicative
14import Control.Exception (displayException, try)
14import Control.Exception (displayException, try)
15import Control.Lens (ifor, ifor_, (.~))
15import Control.Lens (ifor, ifor_, (.~))
16import Control.Monad
16import Control.Monad
17−import Control.Monad.Extra (findM, unlessM, whenM)
17+import Control.Monad.Extra (findM)
18import Control.Monad.Catch (MonadCatch, handle)
18import Control.Monad.Catch (MonadCatch, handle)
19import Control.Monad.Except
19import Control.Monad.Except
20import Data.Aeson ((.=))
20import Data.Aeson ((.=))
21import qualified Data.Aeson as Aeson
21import qualified Data.Aeson as Aeson
22import Data.Aeson.Encode.Pretty
22import Data.Aeson.Encode.Pretty
23import qualified Data.Aeson.Types as Aeson
23import qualified Data.Aeson.Types as Aeson
24+import Data.Bifunctor (first)
24import qualified Data.ByteString.Lazy as LBS
25import qualified Data.ByteString.Lazy as LBS
25import Data.Containers.ListUtils (nubOrd)
26import Data.Containers.ListUtils (nubOrd)
26import Data.Default
27import Data.Default
@@ -55,7 +56,7 @@ import System.Exit
55import System.FilePath
56import System.FilePath
56import System.IO.Error
57import System.IO.Error
57import System.IO.Temp
58import System.IO.Temp
58−import System.Posix (getSymbolicLinkStatus, modificationTime)
59+import System.PosixCompat.Files (getSymbolicLinkStatus, modificationTime)
59import qualified Text.URI as URI
60import qualified Text.URI as URI
61import Obelisk.App (MonadObelisk)
62import Obelisk.App (MonadObelisk)
@@ -64,9 +65,9 @@ import Obelisk.Command.Utils
65--TODO: Support symlinked thunk data
66--TODO: Support symlinked thunk data
66data ThunkData
67data ThunkData
67− = ThunkData_Packed (ThunkSpec, ThunkPtr)
68+ = ThunkData_Packed ThunkSpec ThunkPtr
68 -- ^ Packed thunk
69 -- ^ Packed thunk
69− | ThunkData_Checkout (Maybe (ThunkSpec, ThunkPtr))
70+ | ThunkData_Checkout
70 -- ^ Checked out thunk that was unpacked from this pointer
71 -- ^ Checked out thunk that was unpacked from this pointer
72-- | A reference to the exact data that a thunk should translate into
73-- | A reference to the exact data that a thunk should translate into
@@ -93,6 +94,11 @@ data ThunkSource
93 | ThunkSource_Git GitSource
94 | ThunkSource_Git GitSource
94 deriving (Show, Eq, Ord)
95 deriving (Show, Eq, Ord)
97+thunkSourceToGitSource :: ThunkSource -> GitSource
98+thunkSourceToGitSource = \case
99+ ThunkSource_GitHub s -> forgetGithub False s
100+ ThunkSource_Git s -> s
96data GitHubSource = GitHubSource
102data GitHubSource = GitHubSource
97 { _gitHubSource_owner :: Name Owner
103 { _gitHubSource_owner :: Name Owner
98 , _gitHubSource_repo :: Name Repo
104 , _gitHubSource_repo :: Name Repo
@@ -172,14 +178,14 @@ getNixSha256ForUriUnpacked
172getNixSha256ForUriUnpacked uri =
178getNixSha256ForUriUnpacked uri =
173 withExitFailMessage ("nix-prefetch-url: Failed to determine sha256 hash of URL " <> gitUriToText uri) $ do
179 withExitFailMessage ("nix-prefetch-url: Failed to determine sha256 hash of URL " <> gitUriToText uri) $ do
174 [hash] <- fmap T.lines $ readProcessAndLogOutput (Debug, Debug) $
180 [hash] <- fmap T.lines $ readProcessAndLogOutput (Debug, Debug) $
175− proc "nix-prefetch-url" ["--unpack", "--type", "sha256", T.unpack $ gitUriToText uri]
181+ proc nixPrefetchUrlPath ["--unpack", "--type", "sha256", T.unpack $ gitUriToText uri]
176 pure hash
182 pure hash
178nixPrefetchGit :: MonadObelisk m => GitUri -> Text -> Bool -> m NixSha256
184nixPrefetchGit :: MonadObelisk m => GitUri -> Text -> Bool -> m NixSha256
179nixPrefetchGit uri rev fetchSubmodules =
185nixPrefetchGit uri rev fetchSubmodules =
180 withExitFailMessage ("nix-prefetch-git: Failed to determine sha256 hash of Git repo " <> gitUriToText uri <> " at " <> rev) $ do
186 withExitFailMessage ("nix-prefetch-git: Failed to determine sha256 hash of Git repo " <> gitUriToText uri <> " at " <> rev) $ do
181 out <- readProcessAndLogStderr Debug $
187 out <- readProcessAndLogStderr Debug $
182− proc "nix-prefetch-git" $ filter (/="")
188+ proc nixPrefetchGitPath $ filter (/="")
183 [ "--url", T.unpack $ gitUriToText uri
189 [ "--url", T.unpack $ gitUriToText uri
184 , "--rev", T.unpack rev
190 , "--rev", T.unpack rev
185 , if fetchSubmodules then "--fetch-submodules" else ""
191 , if fetchSubmodules then "--fetch-submodules" else ""
@@ -192,23 +198,25 @@ nixPrefetchGit uri rev fetchSubmodules =
193--TODO: Pretty print these
199--TODO: Pretty print these
194data ReadThunkError
200data ReadThunkError
201+ = ReadThunkError_UnrecognizedThunk
195− = ReadThunkError_UnrecognizedPaths (NonEmpty FilePath)
202+ | ReadThunkError_UnrecognizedPaths (NonEmpty FilePath)
196− | ReadThunkError_MissingPaths (NonEmpty FilePath)
203+ | ReadThunkError_MissingPaths (NonEmpty FilePath)
197− | ReadThunkError_UnrecognizedThunk
198− | ReadThunkError_UnparseablePtr FilePath String
204+ | ReadThunkError_UnparseablePtr FilePath String
199− | ReadThunkError_FileError IOError
205+ | ReadThunkError_FileError IOError
200− | ReadThunkError_FileDoesNotMatch FilePath Text
206+ | ReadThunkError_FileDoesNotMatch FilePath Text
207+ | ReadThunkError_UnrecognizedState String
208+ | ReadThunkError_AmbiguousPackedState ThunkPtr ThunkPtr
201− deriving (Show)
209+ deriving (Show)
203unpackedDirName :: FilePath
211unpackedDirName :: FilePath
204−unpackedDirName = "_"
212+unpackedDirName = "."
206attrCacheFileName :: FilePath
214attrCacheFileName :: FilePath
207attrCacheFileName = ".attr-cache"
215attrCacheFileName = ".attr-cache"
209-- | Specification for how a file in a thunk version works.
217-- | Specification for how a file in a thunk version works.
210data ThunkFileSpec
218data ThunkFileSpec
211− = ThunkFileSpec_Ptr (LBS.ByteString -> Either String ThunkPtr) -- ^ This file specifies a parser for 'ThunkPtr' data
219+ = ThunkFileSpec_Ptr (LBS.ByteString -> Either String ThunkPtr) -- ^ This file specifies 'ThunkPtr' data
212 | ThunkFileSpec_FileMatches Text -- ^ This file must match the given content exactly
220 | ThunkFileSpec_FileMatches Text -- ^ This file must match the given content exactly
213 | ThunkFileSpec_CheckoutIndicator -- ^ Existence of this directory indicates that the thunk is unpacked
221 | ThunkFileSpec_CheckoutIndicator -- ^ Existence of this directory indicates that the thunk is unpacked
214 | ThunkFileSpec_AttrCache -- ^ This directory is an attribute cache
222 | ThunkFileSpec_AttrCache -- ^ This directory is an attribute cache
@@ -240,21 +248,25 @@ matchThunkSpecToDir thunkSpec dir dirFiles = do
240 ThunkFileSpec_AttrCache -> Nothing <$ dirMayExist expectedPath
248 ThunkFileSpec_AttrCache -> Nothing <$ dirMayExist expectedPath
241 ThunkFileSpec_CheckoutIndicator -> liftIO (doesDirectoryExist (dir </> expectedPath)) <&> \case
249 ThunkFileSpec_CheckoutIndicator -> liftIO (doesDirectoryExist (dir </> expectedPath)) <&> \case
242 False -> Nothing
250 False -> Nothing
243− True -> Just (ThunkData_Checkout Nothing)
251+ True -> Just ThunkData_Checkout
244 ThunkFileSpec_FileMatches expectedContents -> handle (\(e :: IOError) -> throwError $ ReadThunkError_FileError e) $ do
252 ThunkFileSpec_FileMatches expectedContents -> handle (\(e :: IOError) -> throwError $ ReadThunkError_FileError e) $ do
245 actualContents <- liftIO (T.readFile $ dir </> expectedPath)
253 actualContents <- liftIO (T.readFile $ dir </> expectedPath)
246 case T.strip expectedContents == T.strip actualContents of
254 case T.strip expectedContents == T.strip actualContents of
247 True -> pure Nothing
255 True -> pure Nothing
248 False -> throwError $ ReadThunkError_FileDoesNotMatch (dir </> expectedPath) expectedContents
256 False -> throwError $ ReadThunkError_FileDoesNotMatch (dir </> expectedPath) expectedContents
249 ThunkFileSpec_Ptr parser -> handle (\(e :: IOError) -> throwError $ ReadThunkError_FileError e) $ do
257 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
250− actualContents <- liftIO $ LBS.readFile $ dir </> expectedPath
262+ actualContents <- liftIO $ LBS.readFile path
251− case parser actualContents of
263+ case parser actualContents of
252− Right v -> pure $ Just (ThunkData_Packed (thunkSpec, v))
264+ Right v -> pure $ Just (ThunkData_Packed thunkSpec v)
253− Left e -> throwError $ ReadThunkError_UnparseablePtr (dir </> expectedPath) e
265+ Left e -> throwError $ ReadThunkError_UnparseablePtr (dir </> expectedPath) e
255 case nonEmpty datas of
267 case nonEmpty datas of
256 Nothing -> throwError ReadThunkError_UnrecognizedThunk
268 Nothing -> throwError ReadThunkError_UnrecognizedThunk
257− Just xs -> fold1WithM xs $ \a b -> maybe (throwError ReadThunkError_UnrecognizedThunk) pure (mergeThunkData a b)
269+ Just xs -> fold1WithM xs $ \a b -> either throwError pure (mergeThunkData a b)
259 rootPathsOnly = Set.fromList . mapMaybe takeRootDir . Map.keys
271 rootPathsOnly = Set.fromList . mapMaybe takeRootDir . Map.keys
260 takeRootDir = fmap NonEmpty.head . nonEmpty . splitPath
272 takeRootDir = fmap NonEmpty.head . nonEmpty . splitPath
@@ -264,7 +276,6 @@ matchThunkSpecToDir thunkSpec dir dirFiles = do
264 requiredPaths = rootPathsOnly $ Map.filter isRequiredFileSpec $ _thunkSpec_files thunkSpec
276 requiredPaths = rootPathsOnly $ Map.filter isRequiredFileSpec $ _thunkSpec_files thunkSpec
265 isRequiredFileSpec = \case
277 isRequiredFileSpec = \case
266 ThunkFileSpec_FileMatches _ -> True
278 ThunkFileSpec_FileMatches _ -> True
267− ThunkFileSpec_Ptr _ -> True
268 _ -> False
279 _ -> False
270 dirMayExist expectedPath = liftIO (doesFileExist (dir </> expectedPath)) >>= \case
281 dirMayExist expectedPath = liftIO (doesFileExist (dir </> expectedPath)) >>= \case
@@ -272,14 +283,13 @@ matchThunkSpecToDir thunkSpec dir dirFiles = do
272 False -> pure ()
283 False -> pure ()
274 -- Combine 'ThunkData' from different files, preferring "Checkout" over "Packed"
285 -- Combine 'ThunkData' from different files, preferring "Checkout" over "Packed"
275− mergeThunkData a@(ThunkData_Checkout _) (ThunkData_Checkout Nothing) = Just a
286+ mergeThunkData ThunkData_Checkout ThunkData_Checkout = Right ThunkData_Checkout
276− mergeThunkData (ThunkData_Checkout Nothing) b@(ThunkData_Checkout _) = Just b
277− mergeThunkData a@(ThunkData_Checkout (Just _)) (ThunkData_Packed _) = Just a
287+ mergeThunkData ThunkData_Checkout ThunkData_Packed{} = Left bothPackedAndUnpacked
278− mergeThunkData (ThunkData_Packed _) b@(ThunkData_Checkout (Just _)) = Just b
288+ mergeThunkData ThunkData_Packed{} ThunkData_Checkout = Left bothPackedAndUnpacked
279− mergeThunkData (ThunkData_Packed a) (ThunkData_Checkout Nothing) = Just $ ThunkData_Checkout $ Just a
289+ mergeThunkData a@(ThunkData_Packed _ ptrA) (ThunkData_Packed _ ptrB) =
280− mergeThunkData (ThunkData_Checkout Nothing) (ThunkData_Packed b) = Just $ ThunkData_Checkout $ Just b
290+ if ptrA == ptrB then Right a else Left $ ReadThunkError_AmbiguousPackedState ptrA ptrB
281− mergeThunkData a@(ThunkData_Checkout (Just (_, ptrA))) (ThunkData_Checkout (Just (_, ptrB))) = if ptrA == ptrB then Just a else Nothing
291+
282− mergeThunkData a@(ThunkData_Packed (_, ptrA)) (ThunkData_Packed (_, ptrB)) = if ptrA == ptrB then Just a else Nothing
292+ bothPackedAndUnpacked = ReadThunkError_UnrecognizedState "Both packed data and checkout present"
284 fold1WithM (x :| xs) f = foldM f x xs
294 fold1WithM (x :| xs) f = foldM f x xs
@@ -292,7 +302,7 @@ readThunkWith specTypes dir = do
292 flip fix specs $ \loop -> \case
302 flip fix specs $ \loop -> \case
293 [] -> pure $ Left ReadThunkError_UnrecognizedThunk
303 [] -> pure $ Left ReadThunkError_UnrecognizedThunk
294 spec:rest -> runExceptT (matchThunkSpecToDir spec dir dirFiles) >>= \case
304 spec:rest -> runExceptT (matchThunkSpecToDir spec dir dirFiles) >>= \case
295− Left e -> loop rest <* putLog Debug [i|Thunk specification ${_thunkSpec_name spec} did not match ${dir}: ${e}|]
305+ Left e -> putLog Debug [i|Thunk specification ${_thunkSpec_name spec} did not match ${dir}: ${e}|] *> loop rest
296 x@(Right _) -> x <$ putLog Debug [i|Thunk specification ${_thunkSpec_name spec} matched ${dir}|]
306 x@(Right _) -> x <$ putLog Debug [i|Thunk specification ${_thunkSpec_name spec} matched ${dir}|]
298-- | Read a thunk and validate that it is exactly a packed thunk.
308-- | Read a thunk and validate that it is exactly a packed thunk.
@@ -347,8 +357,8 @@ overwriteThunk target thunk = do
347 Right _ -> pure ()
357 Right _ -> pure ()
349 --TODO: Is there a safer way to do this overwriting?
359 --TODO: Is there a safer way to do this overwriting?
350− callProcessAndLogOutput (Debug, Error) $ proc rmPath ["-r", target] -- target may be a symlink
360+ liftIO $ removePathForcibly target
351− createThunk target thunk
361+ createThunk target $ Right thunk
353thunkPtrToSpec :: ThunkPtr -> ThunkSpec
363thunkPtrToSpec :: ThunkPtr -> ThunkSpec
354thunkPtrToSpec thunk = case _thunkPtr_source thunk of
364thunkPtrToSpec thunk = case _thunkPtr_source thunk of
@@ -400,28 +410,16 @@ encodeThunkPtrData (ThunkPtr rev src) = case src of
400 , confTrailingNewline = True
410 , confTrailingNewline = True
403−-- | Initialize a git repository to an unpacked thunk.
404−initThunk :: MonadObelisk m => FilePath -> m ()
413+createThunk :: MonadObelisk m => FilePath -> Either ThunkSpec ThunkPtr -> m ()
405−initThunk target = withSpinner [i|Initializing thunk at ${target}|] $ do
406− checkThunkDirectory target
407− unlessM (liftIO $ doesDirectoryExist $ target </> ".git") $ failWith [i|${target} is not a git checkout.|]
408− ptr <- getThunkPtr False target Nothing
409− let tempThunkDir = target <.> "thunk-init"
410− whenM (liftIO $ doesPathExist tempThunkDir) $
411− failWith [i|A previous 'thunk init' left unfinished state at ${tempThunkDir}. You will need to rename or remove that path before trying again.|]
412− createThunk tempThunkDir ptr
414− renameDirectory target (tempThunkDir </> unpackedDirName)
415− removePathForcibly target
416− renameDirectory tempThunkDir target
418−createThunk :: MonadObelisk m => FilePath -> ThunkPtr -> m ()
419−createThunk target ptr =
414+createThunk target ptrInfo =
420− ifor_ (_thunkSpec_files $ thunkPtrToSpec ptr) $ \path -> \case
415+ ifor_ (_thunkSpec_files spec) $ \path -> \case
421 ThunkFileSpec_FileMatches content -> withReadyPath path $ \p -> liftIO $ T.writeFile p content
416 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
422− ThunkFileSpec_Ptr _ -> withReadyPath path $ \p -> liftIO $ LBS.writeFile p (encodeThunkPtrData ptr)
419+ Right ptr -> withReadyPath path $ \p -> liftIO $ LBS.writeFile p (encodeThunkPtrData ptr)
423 _ -> pure ()
420 _ -> pure ()
422+ spec = either id thunkPtrToSpec ptrInfo
425 withReadyPath path f = do
423 withReadyPath path f = do
426 let fullPath = target </> path
424 let fullPath = target </> path
427 putLog Debug $ "Writing thunk file " <> T.pack fullPath
425 putLog Debug $ "Writing thunk file " <> T.pack fullPath
@@ -431,7 +429,7 @@ createThunk target ptr =
431createThunkWithLatest :: MonadObelisk m => FilePath -> ThunkSource -> m ()
429createThunkWithLatest :: MonadObelisk m => FilePath -> ThunkSource -> m ()
432createThunkWithLatest target s = do
430createThunkWithLatest target s = do
433 rev <- getLatestRev s
431 rev <- getLatestRev s
434− createThunk target $ ThunkPtr
432+ createThunk target $ Right $ ThunkPtr
435 { _thunkPtr_source = s
433 { _thunkPtr_source = s
436 , _thunkPtr_rev = rev
434 , _thunkPtr_rev = rev
@@ -443,10 +441,10 @@ updateThunkToLatest (ThunkUpdateConfig mBranch thunkConfig) target = spinner $ d
443 case mBranch of
441 case mBranch of
444 Nothing -> do
442 Nothing -> do
445 (overwrite, ptr) <- readThunk target >>= \case
443 (overwrite, ptr) <- readThunk target >>= \case
446− Left err -> failWith $ T.pack $ "thunk update: " <> show err
444+ Left err -> failWith [i|Thunk update: ${err}|]
447 Right c -> case c of
445 Right c -> case c of
448− ThunkData_Packed (_, t) -> return (target, t)
446+ ThunkData_Packed _ t -> return (target, t)
449− ThunkData_Checkout _ -> failWith "cannot update an unpacked thunk"
447+ ThunkData_Checkout -> failWith "cannot update an unpacked thunk"
450 let src = _thunkPtr_source ptr
448 let src = _thunkPtr_source ptr
451 rev <- getLatestRev src
449 rev <- getLatestRev src
452 overwriteThunk overwrite $ modifyThunkPtrByConfig thunkConfig $ ThunkPtr
450 overwriteThunk overwrite $ modifyThunkPtrByConfig thunkConfig $ ThunkPtr
@@ -454,14 +452,10 @@ updateThunkToLatest (ThunkUpdateConfig mBranch thunkConfig) target = spinner $ d
454 , _thunkPtr_rev = rev
452 , _thunkPtr_rev = rev
456 Just branch -> readThunk target >>= \case
454 Just branch -> readThunk target >>= \case
457− Left err -> failWith $ T.pack $ "thunk update: " <> show err
455+ Left err -> failWith [i|Thunk update: ${err}|]
458 Right c -> case c of
456 Right c -> case c of
459− ThunkData_Packed (_, t) -> case _thunkPtr_source t of
457+ ThunkData_Packed _ t -> setThunk thunkConfig target (thunkSourceToGitSource $ _thunkPtr_source t) branch
460− ThunkSource_Git tsg -> setThunk thunkConfig target tsg branch
461− ThunkSource_GitHub tsgh -> do
462− let tsg = forgetGithub False tsgh
463− setThunk thunkConfig target tsg branch
464− 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."
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.|]
466 spinner = withSpinner' ("Updating thunk " <> T.pack target <> " to latest") (pure $ const $ "Thunk " <> T.pack target <> " updated to latest")
460 spinner = withSpinner' ("Updating thunk " <> T.pack target <> " to latest") (pure $ const $ "Thunk " <> T.pack target <> " updated to latest")
@@ -546,7 +540,8 @@ let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256
546 } else (import <nixpkgs> {}).fetchFromGitHub {
540 } else (import <nixpkgs> {}).fetchFromGitHub {
547 inherit owner repo rev sha256 fetchSubmodules private;
541 inherit owner repo rev sha256 fetchSubmodules private;
549−in if builtins.pathExists ./_ then ./_ else fetch (builtins.fromJSON (builtins.readFile ./github.json))
543+ json = builtins.fromJSON (builtins.readFile ./github.json);
552parseGitHubJsonBytes :: LBS.ByteString -> Either String ThunkPtr
547parseGitHubJsonBytes :: LBS.ByteString -> Either String ThunkPtr
@@ -637,7 +632,8 @@ let fetch = {url, rev, branch ? null, sha256 ? null, fetchSubmodules ? false, pr
637 } else (import <nixpkgs> {}).fetchgit {
632 } else (import <nixpkgs> {}).fetchgit {
638 url = realUrl; inherit rev sha256;
633 url = realUrl; inherit rev sha256;
640−in if builtins.pathExists ./_ then ./_ else fetch (builtins.fromJSON (builtins.readFile ./git.json))
635+ json = builtins.fromJSON (builtins.readFile ./git.json);
643parseGitJsonBytes :: LBS.ByteString -> Either String ThunkPtr
639parseGitJsonBytes :: LBS.ByteString -> Either String ThunkPtr
@@ -646,15 +642,15 @@ parseGitJsonBytes = parseJsonObject $ parseThunkPtr $ fmap ThunkSource_Git . par
646mkThunkSpec :: Text -> FilePath -> (LBS.ByteString -> Either String ThunkPtr) -> Text -> ThunkSpec
642mkThunkSpec :: Text -> FilePath -> (LBS.ByteString -> Either String ThunkPtr) -> Text -> ThunkSpec
647mkThunkSpec name jsonFileName parser srcNix = ThunkSpec name $ Map.fromList
643mkThunkSpec name jsonFileName parser srcNix = ThunkSpec name $ Map.fromList
648 [ ("default.nix", ThunkFileSpec_FileMatches defaultNixViaSrc)
644 [ ("default.nix", ThunkFileSpec_FileMatches defaultNixViaSrc)
649− , ("src.nix", ThunkFileSpec_FileMatches srcNix)
645+ , ("thunk.nix", ThunkFileSpec_FileMatches srcNix)
650 , (jsonFileName, ThunkFileSpec_Ptr parser)
646 , (jsonFileName, ThunkFileSpec_Ptr parser)
651 , (attrCacheFileName, ThunkFileSpec_AttrCache)
647 , (attrCacheFileName, ThunkFileSpec_AttrCache)
652− , (unpackedDirName, ThunkFileSpec_CheckoutIndicator)
648+ , (normalise $ unpackedDirName </> ".git", ThunkFileSpec_CheckoutIndicator)
655 defaultNixViaSrc = [here|
651 defaultNixViaSrc = [here|
656# DO NOT HAND-EDIT THIS FILE
652# DO NOT HAND-EDIT THIS FILE
657−import (import ./src.nix)
653+import (import ./thunk.nix)
@@ -689,7 +685,7 @@ nixBuildThunkAttrWithCache thunkSpec thunkDir attr = do
689 for cachePaths' $ \cachePaths ->
685 for cachePaths' $ \cachePaths ->
690 fmap NonEmpty.head $ for cachePaths $ \cacheDir -> do
686 fmap NonEmpty.head $ for cachePaths $ \cacheDir -> do
692− cachePath = cacheDir </> attr <.> "out"
688+ cachePath = thunkDir </> cacheDir </> attr <.> "out"
693 cacheErrHandler e
689 cacheErrHandler e
694 | isDoesNotExistError e = pure Nothing -- expected from a cache miss
690 | isDoesNotExistError e = pure Nothing -- expected from a cache miss
695 | otherwise = Nothing <$ putLog Error (T.pack $ displayException e)
691 | otherwise = Nothing <$ putLog Error (T.pack $ displayException e)
@@ -722,7 +718,7 @@ nixBuildAttrWithCache
722 -- ^ Symlink to cached or built nix output
718 -- ^ Symlink to cached or built nix output
723nixBuildAttrWithCache exprPath attr = readThunk exprPath >>= \case
719nixBuildAttrWithCache exprPath attr = readThunk exprPath >>= \case
724 -- Only packed thunks are cached. In particular, checkouts are not.
720 -- Only packed thunks are cached. In particular, checkouts are not.
725− Right (ThunkData_Packed (spec, _)) ->
721+ Right (ThunkData_Packed spec _) ->
726 maybe build pure =<< nixBuildThunkAttrWithCache spec exprPath attr
722 maybe build pure =<< nixBuildThunkAttrWithCache spec exprPath attr
727 _ -> build
723 _ -> build
@@ -749,7 +745,7 @@ updateThunk p f = withSystemTempDirectory "obelisk-thunkptr-" $ \tmpDir -> do
750 copyThunkToTmp tmpDir thunkDir = readThunk thunkDir >>= \case
746 copyThunkToTmp tmpDir thunkDir = readThunk thunkDir >>= \case
751 Left err -> failWith $ "withThunkUnpacked: " <> T.pack (show err)
747 Left err -> failWith $ "withThunkUnpacked: " <> T.pack (show err)
752− Right (ThunkData_Packed _) -> do
748+ Right ThunkData_Packed{} -> do
753 let tmpThunk = tmpDir </> "thunk"
749 let tmpThunk = tmpDir </> "thunk"
754 callProcessAndLogOutput (Notice, Error) $
750 callProcessAndLogOutput (Notice, Error) $
755 proc cp ["-r", "-T", thunkDir, tmpThunk]
751 proc cp ["-r", "-T", thunkDir, tmpThunk]
@@ -763,9 +759,6 @@ updateThunk p f = withSystemTempDirectory "obelisk-thunkptr-" $ \tmpDir -> do
763finalMsg :: Bool -> (a -> Text) -> Maybe (a -> Text)
759finalMsg :: Bool -> (a -> Text) -> Maybe (a -> Text)
764finalMsg noTrail s = if noTrail then Nothing else Just s
760finalMsg noTrail s = if noTrail then Nothing else Just s
766−unpackThunk :: MonadObelisk m => FilePath -> m ()
767−unpackThunk = unpackThunk' False
769-- | Check that we are not somewhere inside the thunk directory
762-- | Check that we are not somewhere inside the thunk directory
770checkThunkDirectory :: MonadObelisk m => FilePath -> m ()
763checkThunkDirectory :: MonadObelisk m => FilePath -> m ()
771checkThunkDirectory thunkDir = do
764checkThunkDirectory thunkDir = do
@@ -780,33 +773,51 @@ checkThunkDirectory thunkDir = do
780 Right _ -> failWith [i|Refusing to perform thunk operation on ${thunkDir} because it is a thunk's unpacked source|]
773 Right _ -> failWith [i|Refusing to perform thunk operation on ${thunkDir} because it is a thunk's unpacked source|]
781 Left _ -> pure ()
774 Left _ -> pure ()
776+unpackThunk :: MonadObelisk m => FilePath -> m ()
777+unpackThunk = unpackThunk' False
783unpackThunk' :: MonadObelisk m => Bool -> FilePath -> m ()
779unpackThunk' :: MonadObelisk m => Bool -> FilePath -> m ()
784unpackThunk' noTrail thunkDir = checkThunkDirectory thunkDir *> readThunk thunkDir >>= \case
780unpackThunk' noTrail thunkDir = checkThunkDirectory thunkDir *> readThunk thunkDir >>= \case
785 Left err -> failWith [i|Invalid thunk at ${thunkDir}: ${err}|]
781 Left err -> failWith [i|Invalid thunk at ${thunkDir}: ${err}|]
786 --TODO: Overwrite option that rechecks out thunk; force option to do so even if working directory is dirty
782 --TODO: Overwrite option that rechecks out thunk; force option to do so even if working directory is dirty
787− Right (ThunkData_Checkout _) -> failWith [i|Thunk at ${thunkDir} is already unpacked|]
783+ Right ThunkData_Checkout -> failWith [i|Thunk at ${thunkDir} is already unpacked|]
788− Right (ThunkData_Packed (_, tptr)) -> do
784+ Right (ThunkData_Packed _ tptr) -> do
789 let (thunkParent, thunkName) = splitFileName thunkDir
785 let (thunkParent, thunkName) = splitFileName thunkDir
790− withTempDirectory thunkParent thunkName $ \tmpRepo -> do
786+ withTempDirectory thunkParent thunkName $ \tmpThunk -> do
788+ gitSrc = thunkSourceToGitSource $ _thunkPtr_source tptr
792− s = case _thunkPtr_source tptr of
789+ newSpec = case _thunkPtr_source tptr of
793− ThunkSource_GitHub s' -> forgetGithub False s'
790+ ThunkSource_GitHub _ -> NonEmpty.head gitHubThunkSpecs
794− ThunkSource_Git s' -> s'
791+ ThunkSource_Git _ -> NonEmpty.head gitThunkSpecs
795 withSpinner' ("Fetching thunk " <> T.pack thunkName)
792 withSpinner' ("Fetching thunk " <> T.pack thunkName)
796 (finalMsg noTrail $ const $ "Fetched thunk " <> T.pack thunkName) $ do
793 (finalMsg noTrail $ const $ "Fetched thunk " <> T.pack thunkName) $ do
794+ let unpackedPath = tmpThunk </> unpackedDirName
795+ gitCloneForThunkUnpack gitSrc (_thunkRev_commit $ _thunkPtr_rev tptr) unpackedPath
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
802+ removePathForcibly thunkDir
803+ renameDirectory tmpThunk thunkDir
805+gitCloneForThunkUnpack
807+ => GitSource -- ^ Git source to use
808+ -> Ref hash -- ^ Commit hash to reset to
809+ -> FilePath -- ^ Directory to clone into
811+gitCloneForThunkUnpack gitSrc commit dir = do
797− let git = callProcessAndLogOutput (Notice, Notice) . gitProc tmpRepo
812+ let git = callProcessAndLogOutput (Notice, Notice) . gitProc dir
798− git $ [ "clone" ]
813+ git $ [ "clone" ]
799− ++ ["--recursive" | _gitSource_fetchSubmodules s]
814+ ++ ["--recursive" | _gitSource_fetchSubmodules gitSrc]
800− ++ [ T.unpack $ gitUriToText $ _gitSource_url s ]
815+ ++ [ T.unpack $ gitUriToText $ _gitSource_url gitSrc ]
801− ++ do branch <- maybeToList $ _gitSource_branch s
816+ ++ do branch <- maybeToList $ _gitSource_branch gitSrc
802− [ "--branch", T.unpack $ untagName branch ]
817+ [ "--branch", T.unpack $ untagName branch ]
803− git ["reset", "--hard", Ref.toHexString $ _thunkRev_commit $ _thunkPtr_rev tptr]
818+ git ["reset", "--hard", Ref.toHexString commit]
804− when (_gitSource_fetchSubmodules s) $
819+ when (_gitSource_fetchSubmodules gitSrc) $
805− git ["submodule", "update", "--recursive", "--init"]
820+ git ["submodule", "update", "--recursive", "--init"]
807− let unpackedPath = thunkDir </> unpackedDirName
808− liftIO $ createDirectoryIfMissing True (takeDirectory unpackedPath)
809− callProcessAndLogOutput (Notice, Error) $ proc mvPath [tmpRepo, unpackedPath]
811--TODO: add a rollback mode to pack to the original thunk
822--TODO: add a rollback mode to pack to the original thunk
812packThunk :: MonadObelisk m => ThunkPackConfig -> FilePath -> m ThunkPtr
823packThunk :: MonadObelisk m => ThunkPackConfig -> FilePath -> m ThunkPtr
@@ -814,14 +825,15 @@ packThunk = packThunk' False
815packThunk' :: MonadObelisk m => Bool -> ThunkPackConfig -> FilePath -> m ThunkPtr
826packThunk' :: MonadObelisk m => Bool -> ThunkPackConfig -> FilePath -> m ThunkPtr
816packThunk' noTrail (ThunkPackConfig force thunkConfig) thunkDir = checkThunkDirectory thunkDir *> readThunk thunkDir >>= \case
827packThunk' noTrail (ThunkPackConfig force thunkConfig) thunkDir = checkThunkDirectory thunkDir *> readThunk thunkDir >>= \case
817− Left err -> failWith [i|Can't pack thunk at ${thunkDir}: ${err}|]
818− Right (ThunkData_Packed _) -> failWith [i|Thunk at ${thunkDir} is is already packed|]
828+ Right ThunkData_Packed{} -> failWith [i|Thunk at ${thunkDir} is is already packed|]
819− Right (ThunkData_Checkout _) -> do
829+ _ -> withSpinner'
820− withSpinner' ("Packing thunk " <> T.pack thunkDir)
830+ ("Packing thunk " <> T.pack thunkDir)
821− (finalMsg noTrail $ const $ "Packed thunk " <> T.pack thunkDir) $ do
831+ (finalMsg noTrail $ const $ "Packed thunk " <> T.pack thunkDir) $
833+ let checkClean = if force then CheckClean_NoCheck else CheckClean_FullCheck
822− thunkPtr <- modifyThunkPtrByConfig thunkConfig <$> getThunkPtr (not force) thunkDir (_thunkConfig_private thunkConfig)
834+ thunkPtr <- modifyThunkPtrByConfig thunkConfig <$> getThunkPtr checkClean thunkDir (_thunkConfig_private thunkConfig)
823− callProcessAndLogOutput (Debug, Error) $ proc rmPath ["-rf", thunkDir] -- thunkDir may be a symlink
835+ liftIO $ removePathForcibly thunkDir
824− createThunk thunkDir thunkPtr
836+ createThunk thunkDir $ Right thunkPtr
825 pure thunkPtr
837 pure thunkPtr
827modifyThunkPtrByConfig :: ThunkConfig -> ThunkPtr -> ThunkPtr
839modifyThunkPtrByConfig :: ThunkConfig -> ThunkPtr -> ThunkPtr
@@ -832,15 +844,28 @@ modifyThunkPtrByConfig (ThunkConfig markPrivate') ptr = case markPrivate' of
832 ThunkSource_GitHub s -> ThunkSource_GitHub $ s { _gitHubSource_private = markPrivate }
844 ThunkSource_GitHub s -> ThunkSource_GitHub $ s { _gitHubSource_private = markPrivate }
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
835−getThunkPtr :: forall m. MonadObelisk m => Bool -> FilePath -> Maybe Bool -> m ThunkPtr
855+getThunkPtr :: forall m. MonadObelisk m => CheckClean -> FilePath -> Maybe Bool -> m ThunkPtr
836−getThunkPtr checkClean dir mPrivate = do
856+getThunkPtr gitCheckClean dir mPrivate = do
857+ let repoLocations = nubOrd $ map (first normalise)
837− let repoLocations = [(".git", "."), (unpackedDirName, unpackedDirName)]
858+ [(".git", "."), (unpackedDirName </> ".git", unpackedDirName)]
838 repoLocation' <- liftIO $ flip findM repoLocations $ doesDirectoryExist . (dir </>) . fst
859 repoLocation' <- liftIO $ flip findM repoLocations $ doesDirectoryExist . (dir </>) . fst
839 thunkDir <- case repoLocation' of
860 thunkDir <- case repoLocation' of
840 Nothing -> failWith [i|Can't find an unpacked thunk in ${dir}|]
861 Nothing -> failWith [i|Can't find an unpacked thunk in ${dir}|]
841 Just (_, path) -> pure $ normalise $ dir </> path
862 Just (_, path) -> pure $ normalise $ dir </> path
864+ let (checkClean, checkIgnored) = case gitCheckClean of
865+ CheckClean_FullCheck -> (True, True)
866+ CheckClean_NotIgnored -> (True, False)
867+ CheckClean_NoCheck -> (False, False)
843− when checkClean $ ensureCleanGitRepo thunkDir True
868+ when checkClean $ ensureCleanGitRepo thunkDir checkIgnored
844 "thunk pack: thunk checkout contains unsaved modifications"
869 "thunk pack: thunk checkout contains unsaved modifications"
846 -- Check whether there are any stashes
871 -- Check whether there are any stashes
@@ -956,9 +981,7 @@ getThunkPtr checkClean dir mPrivate = do
956-- | Get the latest revision available from the given source
981-- | Get the latest revision available from the given source
957getLatestRev :: MonadObelisk m => ThunkSource -> m ThunkRev
982getLatestRev :: MonadObelisk m => ThunkSource -> m ThunkRev
958getLatestRev os = do
983getLatestRev os = do
959− let gitS = case os of
984+ let gitS = thunkSourceToGitSource os
960− ThunkSource_GitHub s -> forgetGithub False s
961− ThunkSource_Git s -> s
962 (_, commit) <- gitGetCommitBranch (_gitSource_url gitS) (untagName <$> _gitSource_branch gitS)
985 (_, commit) <- gitGetCommitBranch (_gitSource_url gitS) (untagName <$> _gitSource_branch gitS)
963 case os of
986 case os of
964 ThunkSource_GitHub s -> githubThunkRev s commit
987 ThunkSource_GitHub s -> githubThunkRev s commit