@@ -21,12 +21,14 @@ import 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
27import Data.Either.Combinators (fromRight', rightToMaybe)
28import Data.Either.Combinators (fromRight', rightToMaybe)
28import Data.Foldable (toList)
29import Data.Foldable (toList)
29import Data.Function ((&))
30import Data.Function ((&))
31+import Data.Functor ((<&>))
30import Data.Git.Ref (Ref)
32import Data.Git.Ref (Ref)
31import qualified Data.Git.Ref as Ref
33import qualified Data.Git.Ref as Ref
32import qualified Data.List as L
34import qualified Data.List as L
@@ -54,7 +56,7 @@ import System.Exit
54import System.FilePath
56import System.FilePath
55import System.IO.Error
57import System.IO.Error
56import System.IO.Temp
58import System.IO.Temp
57−import System.Posix (getSymbolicLinkStatus, modificationTime)
59+import System.PosixCompat.Files (getSymbolicLinkStatus, modificationTime)
58import qualified Text.URI as URI
60import qualified Text.URI as URI
60import Obelisk.App (MonadObelisk)
62import Obelisk.App (MonadObelisk)
@@ -63,9 +65,9 @@ import Obelisk.Command.Utils
64--TODO: Support symlinked thunk data
66--TODO: Support symlinked thunk data
65data ThunkData
67data ThunkData
66− = ThunkData_Packed (ThunkSpec, ThunkPtr)
68+ = ThunkData_Packed ThunkSpec ThunkPtr
67 -- ^ Packed thunk
69 -- ^ Packed thunk
68− | ThunkData_Checkout (Maybe (ThunkSpec, ThunkPtr))
70+ | ThunkData_Checkout
69 -- ^ Checked out thunk that was unpacked from this pointer
71 -- ^ Checked out thunk that was unpacked from this pointer
71-- | 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
@@ -92,6 +94,11 @@ data ThunkSource
92 | ThunkSource_Git GitSource
94 | ThunkSource_Git GitSource
93 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
95data GitHubSource = GitHubSource
102data GitHubSource = GitHubSource
96 { _gitHubSource_owner :: Name Owner
103 { _gitHubSource_owner :: Name Owner
97 , _gitHubSource_repo :: Name Repo
104 , _gitHubSource_repo :: Name Repo
@@ -171,14 +178,14 @@ getNixSha256ForUriUnpacked
171getNixSha256ForUriUnpacked uri =
178getNixSha256ForUriUnpacked uri =
172 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
173 [hash] <- fmap T.lines $ readProcessAndLogOutput (Debug, Debug) $
180 [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]
175 pure hash
182 pure hash
177nixPrefetchGit :: MonadObelisk m => GitUri -> Text -> Bool -> m NixSha256
184nixPrefetchGit :: MonadObelisk m => GitUri -> Text -> Bool -> m NixSha256
178nixPrefetchGit uri rev fetchSubmodules =
185nixPrefetchGit uri rev fetchSubmodules =
179 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
180 out <- readProcessAndLogStderr Debug $
187 out <- readProcessAndLogStderr Debug $
181− proc "nix-prefetch-git" $ filter (/="")
188+ proc nixPrefetchGitPath $ filter (/="")
182 [ "--url", T.unpack $ gitUriToText uri
189 [ "--url", T.unpack $ gitUriToText uri
183 , "--rev", T.unpack rev
190 , "--rev", T.unpack rev
184 , if fetchSubmodules then "--fetch-submodules" else ""
191 , if fetchSubmodules then "--fetch-submodules" else ""
@@ -191,61 +198,28 @@ nixPrefetchGit uri rev fetchSubmodules =
192--TODO: Pretty print these
199--TODO: Pretty print these
193data ReadThunkError
200data ReadThunkError
201+ = ReadThunkError_UnrecognizedThunk
194− = ReadThunkError_UnrecognizedPaths (NonEmpty FilePath)
202+ | ReadThunkError_UnrecognizedPaths (NonEmpty FilePath)
195− | ReadThunkError_MissingPaths (NonEmpty FilePath)
203+ | ReadThunkError_MissingPaths (NonEmpty FilePath)
196− | ReadThunkError_UnrecognizedThunk -- TODO: Delete?
197− | ReadThunkError_UnparseablePtr FilePath String
204+ | ReadThunkError_UnparseablePtr FilePath String
198− | ReadThunkError_FileError IOError
205+ | ReadThunkError_FileError IOError
199− | ReadThunkError_FileDoesNotMatch FilePath Text
206+ | ReadThunkError_FileDoesNotMatch FilePath Text
200− deriving (Show)
207+ | ReadThunkError_UnrecognizedState String
201−
208+ | ReadThunkError_AmbiguousPackedState ThunkPtr ThunkPtr
203−data ThunkCheckoutPaths = ThunkCheckoutPaths
204− { _thunkCheckoutPaths_isCheckoutIfExists :: FilePath
205− , _thunkCheckoutPaths_origThunkPath :: FilePath
206− } deriving (Show)
209+ deriving (Show)
208−thunkCheckoutPaths :: NonEmpty ThunkCheckoutPaths
211− { _thunkCheckoutPaths_isCheckoutIfExists = unpackedDirName
212− , _thunkCheckoutPaths_origThunkPath = "."
216− { _thunkCheckoutPaths_isCheckoutIfExists = ".git"
217− , _thunkCheckoutPaths_origThunkPath = ".git" </> "obelisk" </> "orig-thunk"
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)
236unpackedDirName :: FilePath
211unpackedDirName :: FilePath
237−unpackedDirName = "_"
212+unpackedDirName = "."
239attrCacheFileName :: FilePath
214attrCacheFileName :: FilePath
240attrCacheFileName = ".attr-cache"
215attrCacheFileName = ".attr-cache"
242-- | Specification for how a file in a thunk version works.
217-- | Specification for how a file in a thunk version works.
243data ThunkFileSpec
218data ThunkFileSpec
244− = ThunkFileSpec_FileMayExist
245− | ThunkFileSpec_DirMayExist
246− | ThunkFileSpec_AttrCache
247− | ThunkFileSpec_Ptr (LBS.ByteString -> Either String ThunkPtr)
219+ = ThunkFileSpec_Ptr (LBS.ByteString -> Either String ThunkPtr) -- ^ This file specifies 'ThunkPtr' data
248− | ThunkFileSpec_FileMatches Text
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
250-- | Specification for how a set of files in a thunk version work.
224-- | Specification for how a set of files in a thunk version work.
251data ThunkSpec = ThunkSpec
225data ThunkSpec = ThunkSpec
@@ -262,7 +236,7 @@ matchThunkSpecToDir
262 => ThunkSpec -- ^ 'ThunkSpec' to match against the given files/directory
236 => ThunkSpec -- ^ 'ThunkSpec' to match against the given files/directory
263 -> FilePath -- ^ Path to directory
237 -> FilePath -- ^ Path to directory
264 -> Set FilePath -- ^ Set of file paths relative to the given directory
238 -> Set FilePath -- ^ Set of file paths relative to the given directory
265− -> m ThunkPtr
239+ -> m ThunkData
266matchThunkSpecToDir thunkSpec dir dirFiles = do
240matchThunkSpecToDir thunkSpec dir dirFiles = do
267 case nonEmpty (toList $ dirFiles `Set.difference` expectedPaths) of
241 case nonEmpty (toList $ dirFiles `Set.difference` expectedPaths) of
268 Just fs -> throwError $ ReadThunkError_UnrecognizedPaths $ (dir </>) <$> fs
242 Just fs -> throwError $ ReadThunkError_UnrecognizedPaths $ (dir </>) <$> fs
@@ -270,57 +244,71 @@ matchThunkSpecToDir thunkSpec dir dirFiles = do
270 case nonEmpty (toList $ requiredPaths `Set.difference` dirFiles) of
244 case nonEmpty (toList $ requiredPaths `Set.difference` dirFiles) of
271 Just fs -> throwError $ ReadThunkError_MissingPaths $ (dir </>) <$> fs
245 Just fs -> throwError $ ReadThunkError_MissingPaths $ (dir </>) <$> fs
272 Nothing -> pure ()
246 Nothing -> pure ()
273− ptrs <- fmap toList $ flip Map.traverseMaybeWithKey (_thunkSpec_files thunkSpec) $ \expectedPath -> \case
247+ datas <- fmap toList $ flip Map.traverseMaybeWithKey (_thunkSpec_files thunkSpec) $ \expectedPath -> \case
248+ ThunkFileSpec_AttrCache -> Nothing <$ dirMayExist expectedPath
274− ThunkFileSpec_FileMayExist -> liftIO (doesDirectoryExist (dir </> expectedPath)) >>= \case
249+ ThunkFileSpec_CheckoutIndicator -> liftIO (doesDirectoryExist (dir </> expectedPath)) <&> \case
275− True -> throwError $ ReadThunkError_UnrecognizedPaths $ expectedPath :| []
250+ False -> Nothing
276− False -> pure Nothing
251+ True -> Just ThunkData_Checkout
277− ThunkFileSpec_DirMayExist -> dirMayExist expectedPath
278− ThunkFileSpec_AttrCache -> dirMayExist expectedPath
279 ThunkFileSpec_FileMatches expectedContents -> handle (\(e :: IOError) -> throwError $ ReadThunkError_FileError e) $ do
252 ThunkFileSpec_FileMatches expectedContents -> handle (\(e :: IOError) -> throwError $ ReadThunkError_FileError e) $ do
280 actualContents <- liftIO (T.readFile $ dir </> expectedPath)
253 actualContents <- liftIO (T.readFile $ dir </> expectedPath)
281 case T.strip expectedContents == T.strip actualContents of
254 case T.strip expectedContents == T.strip actualContents of
282 True -> pure Nothing
255 True -> pure Nothing
283 False -> throwError $ ReadThunkError_FileDoesNotMatch (dir </> expectedPath) expectedContents
256 False -> throwError $ ReadThunkError_FileDoesNotMatch (dir </> expectedPath) expectedContents
284 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
285− actualContents <- liftIO $ LBS.readFile $ dir </> expectedPath
262+ actualContents <- liftIO $ LBS.readFile path
286− case parser actualContents of
263+ case parser actualContents of
287− Right v -> pure $ Just v
264+ Right v -> pure $ Just (ThunkData_Packed thunkSpec v)
288− Left e -> throwError $ ReadThunkError_UnparseablePtr (dir </> expectedPath) e
265+ Left e -> throwError $ ReadThunkError_UnparseablePtr (dir </> expectedPath) e
267+ case nonEmpty datas of
268+ Nothing -> throwError ReadThunkError_UnrecognizedThunk
269+ Just xs -> fold1WithM xs $ \a b -> either throwError pure (mergeThunkData a b)
271+ rootPathsOnly = Set.fromList . mapMaybe takeRootDir . Map.keys
272+ takeRootDir = fmap NonEmpty.head . nonEmpty . splitPath
290− case nubOrd ptrs of
274+ expectedPaths = rootPathsOnly $ _thunkSpec_files thunkSpec
292− _ -> throwError ReadThunkError_UnrecognizedThunk
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
297 isRequiredFileSpec = \case
277 isRequiredFileSpec = \case
298 ThunkFileSpec_FileMatches _ -> True
278 ThunkFileSpec_FileMatches _ -> True
299− ThunkFileSpec_Ptr _ -> True
300 _ -> False
279 _ -> False
302 dirMayExist expectedPath = liftIO (doesFileExist (dir </> expectedPath)) >>= \case
281 dirMayExist expectedPath = liftIO (doesFileExist (dir </> expectedPath)) >>= \case
303 True -> throwError $ ReadThunkError_UnrecognizedPaths $ expectedPath :| []
282 True -> throwError $ ReadThunkError_UnrecognizedPaths $ expectedPath :| []
304− False -> pure Nothing
283+ False -> pure ()
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
306−readPackedThunkWith
292+ bothPackedAndUnpacked = ReadThunkError_UnrecognizedState "Both packed data and checkout present"
294+ fold1WithM (x :| xs) f = foldM f x xs
307 :: (MonadObelisk m)
297 :: (MonadObelisk m)
308− => NonEmpty (NonEmpty ThunkSpec) -> FilePath -> m (Either ReadThunkError (ThunkSpec, ThunkPtr))
298+ => NonEmpty (NonEmpty ThunkSpec) -> FilePath -> m (Either ReadThunkError ThunkData)
309−readPackedThunkWith specTypes dir = do
299+readThunkWith specTypes dir = do
310 dirFiles <- Set.fromList <$> liftIO (listDirectory dir)
300 dirFiles <- Set.fromList <$> liftIO (listDirectory dir)
311 let specs = concatMap toList $ toList $ NonEmpty.transpose specTypes -- Interleave spec types so we try each one in a "fair" ordering
301 let specs = concatMap toList $ toList $ NonEmpty.transpose specTypes -- Interleave spec types so we try each one in a "fair" ordering
312 flip fix specs $ \loop -> \case
302 flip fix specs $ \loop -> \case
313 [] -> pure $ Left ReadThunkError_UnrecognizedThunk
303 [] -> pure $ Left ReadThunkError_UnrecognizedThunk
314 spec:rest -> runExceptT (matchThunkSpecToDir spec dir dirFiles) >>= \case
304 spec:rest -> runExceptT (matchThunkSpecToDir spec dir dirFiles) >>= \case
316− putLog Debug [i|Thunk ${_thunkSpec_name spec} specification did not match ${dir}: ${e}|]
305+ Left e -> putLog Debug [i|Thunk specification ${_thunkSpec_name spec} did not match ${dir}: ${e}|] *> loop rest
318− Right ptr -> Right (spec, ptr) <$ putLog Debug ("Thunk " <> _thunkSpec_name spec <> " matched " <> T.pack dir)
306+ x@(Right _) -> x <$ putLog Debug [i|Thunk specification ${_thunkSpec_name spec} matched ${dir}|]
320-- | 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.
321-- If additional data is present, fail.
309-- If additional data is present, fail.
322−readPackedThunk :: (MonadObelisk m) => FilePath -> m (Either ReadThunkError (ThunkSpec, ThunkPtr))
310+readThunk :: (MonadObelisk m) => FilePath -> m (Either ReadThunkError ThunkData)
323−readPackedThunk = readPackedThunkWith thunkSpecTypes
311+readThunk = readThunkWith thunkSpecTypes
325parseThunkPtr :: (Aeson.Object -> Aeson.Parser ThunkSource) -> Aeson.Object -> Aeson.Parser ThunkPtr
313parseThunkPtr :: (Aeson.Object -> Aeson.Parser ThunkSource) -> Aeson.Object -> Aeson.Parser ThunkPtr
326parseThunkPtr parseSrc v = do
314parseThunkPtr parseSrc v = do
@@ -369,8 +357,8 @@ overwriteThunk target thunk = do
369 Right _ -> pure ()
357 Right _ -> pure ()
371 --TODO: Is there a safer way to do this overwriting?
359 --TODO: Is there a safer way to do this overwriting?
372− callProcessAndLogOutput (Debug, Error) $ proc rmPath ["-r", target] -- target may be a symlink
360+ liftIO $ removePathForcibly target
373− createThunk target thunk
361+ createThunk target $ Right thunk
375thunkPtrToSpec :: ThunkPtr -> ThunkSpec
363thunkPtrToSpec :: ThunkPtr -> ThunkSpec
376thunkPtrToSpec thunk = case _thunkPtr_source thunk of
364thunkPtrToSpec thunk = case _thunkPtr_source thunk of
@@ -422,13 +410,16 @@ encodeThunkPtrData (ThunkPtr rev src) = case src of
422 , confTrailingNewline = True
410 , confTrailingNewline = True
425−createThunk :: MonadObelisk m => FilePath -> ThunkPtr -> m ()
413+createThunk :: MonadObelisk m => FilePath -> Either ThunkSpec ThunkPtr -> m ()
426−createThunk target ptr =
414+createThunk target ptrInfo =
427− ifor_ (_thunkSpec_files $ thunkPtrToSpec ptr) $ \path -> \case
415+ ifor_ (_thunkSpec_files spec) $ \path -> \case
428 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
429− ThunkFileSpec_Ptr _ -> withReadyPath path $ \p -> liftIO $ LBS.writeFile p (encodeThunkPtrData ptr)
419+ Right ptr -> withReadyPath path $ \p -> liftIO $ LBS.writeFile p (encodeThunkPtrData ptr)
430 _ -> pure ()
420 _ -> pure ()
422+ spec = either id thunkPtrToSpec ptrInfo
432 withReadyPath path f = do
423 withReadyPath path f = do
433 let fullPath = target </> path
424 let fullPath = target </> path
434 putLog Debug $ "Writing thunk file " <> T.pack fullPath
425 putLog Debug $ "Writing thunk file " <> T.pack fullPath
@@ -438,22 +429,22 @@ createThunk target ptr =
438createThunkWithLatest :: MonadObelisk m => FilePath -> ThunkSource -> m ()
429createThunkWithLatest :: MonadObelisk m => FilePath -> ThunkSource -> m ()
439createThunkWithLatest target s = do
430createThunkWithLatest target s = do
440 rev <- getLatestRev s
431 rev <- getLatestRev s
441− createThunk target $ ThunkPtr
432+ createThunk target $ Right $ ThunkPtr
442 { _thunkPtr_source = s
433 { _thunkPtr_source = s
443 , _thunkPtr_rev = rev
434 , _thunkPtr_rev = rev
446updateThunkToLatest :: MonadObelisk m => ThunkUpdateConfig -> FilePath -> m ()
437updateThunkToLatest :: 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
438+updateThunkToLatest (ThunkUpdateConfig mBranch thunkConfig) target = spinner $ do
448− checkThunkDirectory "ob thunk update directory cannot be '.'" target
439+ checkThunkDirectory target
449 -- check to see if thunk should be updated to a specific branch or just update it's current branch
440 -- check to see if thunk should be updated to a specific branch or just update it's current branch
450 case mBranch of
441 case mBranch of
451 Nothing -> do
442 Nothing -> do
452 (overwrite, ptr) <- readThunk target >>= \case
443 (overwrite, ptr) <- readThunk target >>= \case
453− Left err -> failWith $ T.pack $ "thunk update: " <> show err
444+ Left err -> failWith [i|Thunk update: ${err}|]
454 Right c -> case c of
445 Right c -> case c of
455− ThunkData_Packed (_, t) -> return (target, t)
446+ ThunkData_Packed _ t -> return (target, t)
456− ThunkData_Checkout _ -> failWith "cannot update an unpacked thunk"
447+ ThunkData_Checkout -> failWith "cannot update an unpacked thunk"
457 let src = _thunkPtr_source ptr
448 let src = _thunkPtr_source ptr
458 rev <- getLatestRev src
449 rev <- getLatestRev src
459 overwriteThunk overwrite $ modifyThunkPtrByConfig thunkConfig $ ThunkPtr
450 overwriteThunk overwrite $ modifyThunkPtrByConfig thunkConfig $ ThunkPtr
@@ -461,14 +452,12 @@ updateThunkToLatest (ThunkUpdateConfig mBranch thunkConfig) target = withSpinner
461 , _thunkPtr_rev = rev
452 , _thunkPtr_rev = rev
463 Just branch -> readThunk target >>= \case
454 Just branch -> readThunk target >>= \case
464− Left err -> failWith $ T.pack $ "thunk update: " <> show err
455+ Left err -> failWith [i|Thunk update: ${err}|]
465 Right c -> case c of
456 Right c -> case c of
466− ThunkData_Packed (_, t) -> case _thunkPtr_source t of
457+ ThunkData_Packed _ t -> setThunk thunkConfig target (thunkSourceToGitSource $ _thunkPtr_source t) branch
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."
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.|]
460+ spinner = withSpinner' ("Updating thunk " <> T.pack target <> " to latest") (pure $ const $ "Thunk " <> T.pack target <> " updated to latest")
473setThunk :: MonadObelisk m => ThunkConfig -> FilePath -> GitSource -> String -> m ()
462setThunk :: MonadObelisk m => ThunkConfig -> FilePath -> GitSource -> String -> m ()
474setThunk thunkConfig target gs branch = do
463setThunk thunkConfig target gs branch = do
@@ -539,6 +528,7 @@ legacyGitHubThunkSpec name loader = ThunkSpec name $ Map.fromList
539 [ ("default.nix", ThunkFileSpec_FileMatches $ T.strip loader)
528 [ ("default.nix", ThunkFileSpec_FileMatches $ T.strip loader)
540 , ("github.json" , ThunkFileSpec_Ptr parseGitHubJsonBytes)
529 , ("github.json" , ThunkFileSpec_Ptr parseGitHubJsonBytes)
541 , (attrCacheFileName, ThunkFileSpec_AttrCache)
530 , (attrCacheFileName, ThunkFileSpec_AttrCache)
531+ , (".git", ThunkFileSpec_CheckoutIndicator)
544gitHubThunkSpecV5 :: ThunkSpec
534gitHubThunkSpecV5 :: ThunkSpec
@@ -550,7 +540,8 @@ let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256
550 } else (import <nixpkgs> {}).fetchFromGitHub {
540 } else (import <nixpkgs> {}).fetchFromGitHub {
551 inherit owner repo rev sha256 fetchSubmodules private;
541 inherit owner repo rev sha256 fetchSubmodules private;
553−in if builtins.pathExists ./_ then ./_ else fetch (builtins.fromJSON (builtins.readFile ./github.json))
543+ json = builtins.fromJSON (builtins.readFile ./github.json);
556parseGitHubJsonBytes :: LBS.ByteString -> Either String ThunkPtr
547parseGitHubJsonBytes :: LBS.ByteString -> Either String ThunkPtr
@@ -624,6 +615,7 @@ legacyGitThunkSpec name loader = ThunkSpec name $ Map.fromList
624 [ ("default.nix", ThunkFileSpec_FileMatches $ T.strip loader)
615 [ ("default.nix", ThunkFileSpec_FileMatches $ T.strip loader)
625 , ("git.json" , ThunkFileSpec_Ptr parseGitJsonBytes)
616 , ("git.json" , ThunkFileSpec_Ptr parseGitJsonBytes)
626 , (attrCacheFileName, ThunkFileSpec_AttrCache)
617 , (attrCacheFileName, ThunkFileSpec_AttrCache)
618+ , (".git", ThunkFileSpec_CheckoutIndicator)
629gitThunkSpecV5 :: ThunkSpec
621gitThunkSpecV5 :: ThunkSpec
@@ -640,7 +632,8 @@ let fetch = {url, rev, branch ? null, sha256 ? null, fetchSubmodules ? false, pr
640 } else (import <nixpkgs> {}).fetchgit {
632 } else (import <nixpkgs> {}).fetchgit {
641 url = realUrl; inherit rev sha256;
633 url = realUrl; inherit rev sha256;
643−in if builtins.pathExists ./_ then ./_ else fetch (builtins.fromJSON (builtins.readFile ./git.json))
635+ json = builtins.fromJSON (builtins.readFile ./git.json);
646parseGitJsonBytes :: LBS.ByteString -> Either String ThunkPtr
639parseGitJsonBytes :: LBS.ByteString -> Either String ThunkPtr
@@ -649,14 +642,15 @@ parseGitJsonBytes = parseJsonObject $ parseThunkPtr $ fmap ThunkSource_Git . par
649mkThunkSpec :: Text -> FilePath -> (LBS.ByteString -> Either String ThunkPtr) -> Text -> ThunkSpec
642mkThunkSpec :: Text -> FilePath -> (LBS.ByteString -> Either String ThunkPtr) -> Text -> ThunkSpec
650mkThunkSpec name jsonFileName parser srcNix = ThunkSpec name $ Map.fromList
643mkThunkSpec name jsonFileName parser srcNix = ThunkSpec name $ Map.fromList
651 [ ("default.nix", ThunkFileSpec_FileMatches defaultNixViaSrc)
644 [ ("default.nix", ThunkFileSpec_FileMatches defaultNixViaSrc)
652− , ("src.nix", ThunkFileSpec_FileMatches srcNix)
645+ , ("thunk.nix", ThunkFileSpec_FileMatches srcNix)
653 , (jsonFileName, ThunkFileSpec_Ptr parser)
646 , (jsonFileName, ThunkFileSpec_Ptr parser)
654 , (attrCacheFileName, ThunkFileSpec_AttrCache)
647 , (attrCacheFileName, ThunkFileSpec_AttrCache)
648+ , (normalise $ unpackedDirName </> ".git", ThunkFileSpec_CheckoutIndicator)
657 defaultNixViaSrc = [here|
651 defaultNixViaSrc = [here|
658# DO NOT HAND-EDIT THIS FILE
652# DO NOT HAND-EDIT THIS FILE
659−import (import ./src.nix)
653+import (import ./thunk.nix)
@@ -691,7 +685,7 @@ nixBuildThunkAttrWithCache thunkSpec thunkDir attr = do
691 for cachePaths' $ \cachePaths ->
685 for cachePaths' $ \cachePaths ->
692 fmap NonEmpty.head $ for cachePaths $ \cacheDir -> do
686 fmap NonEmpty.head $ for cachePaths $ \cacheDir -> do
694− cachePath = cacheDir </> attr <.> "out"
688+ cachePath = thunkDir </> cacheDir </> attr <.> "out"
695 cacheErrHandler e
689 cacheErrHandler e
696 | isDoesNotExistError e = pure Nothing -- expected from a cache miss
690 | isDoesNotExistError e = pure Nothing -- expected from a cache miss
697 | otherwise = Nothing <$ putLog Error (T.pack $ displayException e)
691 | otherwise = Nothing <$ putLog Error (T.pack $ displayException e)
@@ -724,7 +718,7 @@ nixBuildAttrWithCache
724 -- ^ Symlink to cached or built nix output
718 -- ^ Symlink to cached or built nix output
725nixBuildAttrWithCache exprPath attr = readThunk exprPath >>= \case
719nixBuildAttrWithCache exprPath attr = readThunk exprPath >>= \case
726 -- Only packed thunks are cached. In particular, checkouts are not.
720 -- Only packed thunks are cached. In particular, checkouts are not.
727− Right (ThunkData_Packed (spec, _)) ->
721+ Right (ThunkData_Packed spec _) ->
728 maybe build pure =<< nixBuildThunkAttrWithCache spec exprPath attr
722 maybe build pure =<< nixBuildThunkAttrWithCache spec exprPath attr
729 _ -> build
723 _ -> build
@@ -751,7 +745,7 @@ updateThunk p f = withSystemTempDirectory "obelisk-thunkptr-" $ \tmpDir -> do
752 copyThunkToTmp tmpDir thunkDir = readThunk thunkDir >>= \case
746 copyThunkToTmp tmpDir thunkDir = readThunk thunkDir >>= \case
753 Left err -> failWith $ "withThunkUnpacked: " <> T.pack (show err)
747 Left err -> failWith $ "withThunkUnpacked: " <> T.pack (show err)
754− Right (ThunkData_Packed _) -> do
748+ Right ThunkData_Packed{} -> do
755 let tmpThunk = tmpDir </> "thunk"
749 let tmpThunk = tmpDir </> "thunk"
756 callProcessAndLogOutput (Notice, Error) $
750 callProcessAndLogOutput (Notice, Error) $
757 proc cp ["-r", "-T", thunkDir, tmpThunk]
751 proc cp ["-r", "-T", thunkDir, tmpThunk]
@@ -765,58 +759,81 @@ updateThunk p f = withSystemTempDirectory "obelisk-thunkptr-" $ \tmpDir -> do
765finalMsg :: Bool -> (a -> Text) -> Maybe (a -> Text)
759finalMsg :: Bool -> (a -> Text) -> Maybe (a -> Text)
766finalMsg noTrail s = if noTrail then Nothing else Just s
760finalMsg noTrail s = if noTrail then Nothing else Just s
768−unpackThunk :: MonadObelisk m => FilePath -> m ()
769−unpackThunk = unpackThunk' False
771-- | Check that we are not somewhere inside the thunk directory
762-- | Check that we are not somewhere inside the thunk directory
772−checkThunkDirectory :: MonadObelisk m => Text -> FilePath -> m ()
763+checkThunkDirectory :: MonadObelisk m => FilePath -> m ()
773−checkThunkDirectory msg thunkDir = do
764+checkThunkDirectory thunkDir = do
774 currentDir <- liftIO getCurrentDirectory
765 currentDir <- liftIO getCurrentDirectory
775 thunkDir' <- liftIO $ canonicalizePath thunkDir
766 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}|]
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|]
776+unpackThunk :: MonadObelisk m => FilePath -> m ()
777+unpackThunk = unpackThunk' False
778unpackThunk' :: MonadObelisk m => Bool -> FilePath -> m ()
779unpackThunk' :: 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
780 Left err -> failWith [i|Invalid thunk at ${thunkDir}: ${err}|]
781 Left err -> failWith [i|Invalid thunk at ${thunkDir}: ${err}|]
781 --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
782− Right (ThunkData_Checkout _) -> failWith [i|Thunk at ${thunkDir} is already unpacked|]
783+ Right ThunkData_Checkout -> failWith [i|Thunk at ${thunkDir} is already unpacked|]
783− Right (ThunkData_Packed (_, tptr)) -> do
784+ Right (ThunkData_Packed _ tptr) -> do
784 let (thunkParent, thunkName) = splitFileName thunkDir
785 let (thunkParent, thunkName) = splitFileName thunkDir
785− withTempDirectory thunkParent thunkName $ \tmpRepo -> do
786+ withTempDirectory thunkParent thunkName $ \tmpThunk -> do
788+ gitSrc = thunkSourceToGitSource $ _thunkPtr_source tptr
787− s = case _thunkPtr_source tptr of
789+ newSpec = case _thunkPtr_source tptr of
788− ThunkSource_GitHub s' -> forgetGithub False s'
790+ ThunkSource_GitHub _ -> NonEmpty.head gitHubThunkSpecs
789− ThunkSource_Git s' -> s'
791+ ThunkSource_Git _ -> NonEmpty.head gitThunkSpecs
790 withSpinner' ("Fetching thunk " <> T.pack thunkName)
792 withSpinner' ("Fetching thunk " <> T.pack thunkName)
791 (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
792− let git = callProcessAndLogOutput (Notice, Notice) . gitProc tmpRepo
812+ let git = callProcessAndLogOutput (Notice, Notice) . gitProc dir
793− git $ [ "clone" ]
813+ git $ [ "clone" ]
794− ++ ["--recursive" | _gitSource_fetchSubmodules s]
814+ ++ ["--recursive" | _gitSource_fetchSubmodules gitSrc]
795− ++ [ T.unpack $ gitUriToText $ _gitSource_url s ]
815+ ++ [ T.unpack $ gitUriToText $ _gitSource_url gitSrc ]
796− ++ do branch <- maybeToList $ _gitSource_branch s
816+ ++ do branch <- maybeToList $ _gitSource_branch gitSrc
797− [ "--branch", T.unpack $ untagName branch ]
817+ [ "--branch", T.unpack $ untagName branch ]
798− git ["reset", "--hard", Ref.toHexString $ _thunkRev_commit $ _thunkPtr_rev tptr]
818+ git ["reset", "--hard", Ref.toHexString commit]
799− when (_gitSource_fetchSubmodules s) $
819+ when (_gitSource_fetchSubmodules gitSrc) $
800− git ["submodule", "update", "--recursive", "--init"]
820+ git ["submodule", "update", "--recursive", "--init"]
802− let unpackedPath = thunkDir </> unpackedDirName
803− liftIO $ createDirectoryIfMissing True (takeDirectory unpackedPath)
804− callProcessAndLogOutput (Notice, Error) $ proc mvPath [tmpRepo, unpackedPath]
806--TODO: add a rollback mode to pack to the original thunk
822--TODO: add a rollback mode to pack to the original thunk
807packThunk :: MonadObelisk m => ThunkPackConfig -> FilePath -> m ThunkPtr
823packThunk :: MonadObelisk m => ThunkPackConfig -> FilePath -> m ThunkPtr
808packThunk = packThunk' False
824packThunk = packThunk' False
810packThunk' :: MonadObelisk m => Bool -> ThunkPackConfig -> FilePath -> m ThunkPtr
826packThunk' :: 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
827+packThunk' noTrail (ThunkPackConfig force thunkConfig) thunkDir = checkThunkDirectory 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|]
828+ Right ThunkData_Packed{} -> failWith [i|Thunk at ${thunkDir} is is already packed|]
814− Right (ThunkData_Checkout _) -> do
829+ _ -> withSpinner'
815− withSpinner' ("Packing thunk " <> T.pack thunkDir)
830+ ("Packing thunk " <> T.pack thunkDir)
816− (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
817− thunkPtr <- modifyThunkPtrByConfig thunkConfig <$> getThunkPtr (not force) thunkDir (_thunkConfig_private thunkConfig)
834+ thunkPtr <- modifyThunkPtrByConfig thunkConfig <$> getThunkPtr checkClean thunkDir (_thunkConfig_private thunkConfig)
818− callProcessAndLogOutput (Debug, Error) $ proc rmPath ["-rf", thunkDir] -- thunkDir may be a symlink
835+ liftIO $ removePathForcibly thunkDir
819− createThunk thunkDir thunkPtr
836+ createThunk thunkDir $ Right thunkPtr
820 pure thunkPtr
837 pure thunkPtr
822modifyThunkPtrByConfig :: ThunkConfig -> ThunkPtr -> ThunkPtr
839modifyThunkPtrByConfig :: ThunkConfig -> ThunkPtr -> ThunkPtr
@@ -827,26 +844,38 @@ modifyThunkPtrByConfig (ThunkConfig markPrivate') ptr = case markPrivate' of
827 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
830−getThunkPtr :: forall m. MonadObelisk m => Bool -> FilePath -> Maybe Bool -> m ThunkPtr
855+getThunkPtr :: forall m. MonadObelisk m => CheckClean -> FilePath -> Maybe Bool -> m ThunkPtr
831−getThunkPtr checkClean dir mPrivate = do
856+getThunkPtr gitCheckClean dir mPrivate = do
857+ let repoLocations = nubOrd $ map (first normalise)
832− let repoLocations = [(".git", "."), (unpackedDirName, unpackedDirName)]
858+ [(".git", "."), (unpackedDirName </> ".git", unpackedDirName)]
833 repoLocation' <- liftIO $ flip findM repoLocations $ doesDirectoryExist . (dir </>) . fst
859 repoLocation' <- liftIO $ flip findM repoLocations $ doesDirectoryExist . (dir </>) . fst
834 thunkDir <- case repoLocation' of
860 thunkDir <- case repoLocation' of
835 Nothing -> failWith [i|Can't find an unpacked thunk in ${dir}|]
861 Nothing -> failWith [i|Can't find an unpacked thunk in ${dir}|]
836 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)
838− when checkClean $ ensureCleanGitRepo thunkDir True
868+ when checkClean $ ensureCleanGitRepo thunkDir checkIgnored
839 "thunk pack: thunk checkout contains unsaved modifications"
869 "thunk pack: thunk checkout contains unsaved modifications"
841 -- Check whether there are any stashes
871 -- Check whether there are any stashes
872+ when checkClean $ do
842− stashOutput <- readGitProcess thunkDir ["stash", "list"]
873+ stashOutput <- readGitProcess thunkDir ["stash", "list"]
843− when checkClean $ case T.null stashOutput of
874+ unless (T.null stashOutput) $
845 failWith $ T.unlines $
875 failWith $ T.unlines $
846 [ "thunk pack: thunk checkout has stashes"
876 [ "thunk pack: thunk checkout has stashes"
847 , "git stash list:"
877 , "git stash list:"
848 ] ++ T.lines stashOutput
878 ] ++ T.lines stashOutput
851 -- Get current branch
880 -- Get current branch
852 (mCurrentBranch, mCurrentCommit) <- do
881 (mCurrentBranch, mCurrentCommit) <- do
@@ -862,7 +891,7 @@ getThunkPtr checkClean dir mPrivate = do
863 -- Get information on all branches and their (optional) designated upstream
892 -- Get information on all branches and their (optional) designated upstream
864 -- correspondents
893 -- correspondents
865− (headDump :: [Text]) <- T.lines <$> readGitProcess thunkDir
894+ headDump :: [Text] <- T.lines <$> readGitProcess thunkDir
866 [ "for-each-ref"
895 [ "for-each-ref"
867 , "--format=%(refname:short) %(upstream:short) %(upstream:remotename)"
896 , "--format=%(refname:short) %(upstream:short) %(upstream:remotename)"
868 , "refs/heads/"
897 , "refs/heads/"
@@ -932,8 +961,9 @@ getThunkPtr checkClean dir mPrivate = do
932 \pushed but this repo's remote tracking branches don't know it.)"
961 \pushed but this repo's remote tracking branches don't know it.)"
964+ when checkClean $ do
935− -- We assume it's safe to pack the thunk at this point
965+ -- 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."
966+ putLog Informational "All changes safe in git remotes. OK to pack thunk."
938 let remote = maybe "origin" snd $ flip Map.lookup headUpstream =<< mCurrentBranch
968 let remote = maybe "origin" snd $ flip Map.lookup headUpstream =<< mCurrentBranch
@@ -951,9 +981,7 @@ getThunkPtr checkClean dir mPrivate = do
951-- | Get the latest revision available from the given source
981-- | Get the latest revision available from the given source
952getLatestRev :: MonadObelisk m => ThunkSource -> m ThunkRev
982getLatestRev :: MonadObelisk m => ThunkSource -> m ThunkRev
953getLatestRev os = do
983getLatestRev os = do
954− let gitS = case os of
984+ let gitS = thunkSourceToGitSource os
955− ThunkSource_GitHub s -> forgetGithub False s
956− ThunkSource_Git s -> s
957 (_, commit) <- gitGetCommitBranch (_gitSource_url gitS) (untagName <$> _gitSource_branch gitS)
985 (_, commit) <- gitGetCommitBranch (_gitSource_url gitS) (untagName <$> _gitSource_branch gitS)
958 case os of
986 case os of
959 ThunkSource_GitHub s -> githubThunkRev s commit
987 ThunkSource_GitHub s -> githubThunkRev s commit