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