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