@@ -14,7 +14,7 @@ import Control.Applicative
1414import Control.Exception (displayException, try)
1515import Control.Lens (ifor, ifor_, (.~))
1616import Control.Monad
17−import Control.Monad.Extra (findM)
17+import Control.Monad.Extra (findM, unlessM, whenM)
1818import Control.Monad.Catch (MonadCatch, handle)
1919import Control.Monad.Except
2020import Data.Aeson ((.=))
@@ -27,6 +27,7 @@ import Data.Default
2727import Data.Either.Combinators (fromRight', rightToMaybe)
2828import Data.Foldable (toList)
2929import Data.Function ((&))
30+import Data.Functor ((<&>))
3031import Data.Git.Ref (Ref)
3132import qualified Data.Git.Ref as Ref
3233import qualified Data.List as L
@@ -193,46 +194,12 @@ nixPrefetchGit uri rev fetchSubmodules =
193194data ReadThunkError
194195 = ReadThunkError_UnrecognizedPaths (NonEmpty FilePath)
195196 | ReadThunkError_MissingPaths (NonEmpty FilePath)
196− | ReadThunkError_UnrecognizedThunk -- TODO: Delete?
197+ | ReadThunkError_UnrecognizedThunk
197198 | ReadThunkError_UnparseablePtr FilePath String
198199 | ReadThunkError_FileError IOError
199200 | ReadThunkError_FileDoesNotMatch FilePath Text
200201 deriving (Show)
201202
202−
203−data ThunkCheckoutPaths = ThunkCheckoutPaths
204− { _thunkCheckoutPaths_isCheckoutIfExists :: FilePath
205− , _thunkCheckoutPaths_origThunkPath :: FilePath
206− } deriving (Show)
207−
208−thunkCheckoutPaths :: NonEmpty ThunkCheckoutPaths
209−thunkCheckoutPaths =
210− ThunkCheckoutPaths
211− { _thunkCheckoutPaths_isCheckoutIfExists = unpackedDirName
212− , _thunkCheckoutPaths_origThunkPath = "."
213− }
214− :| [
215− ThunkCheckoutPaths
216− { _thunkCheckoutPaths_isCheckoutIfExists = ".git"
217− , _thunkCheckoutPaths_origThunkPath = ".git" </> "obelisk" </> "orig-thunk"
218− }
219− ]
220−
221−
222−-- | Read a thunk and validate that it is only a thunk, either packed or unpacked.
223−-- If the thunk is packed and additional data is present, fail.
224−readThunk :: MonadObelisk m => FilePath -> m (Either ReadThunkError ThunkData)
225−readThunk thunkDir = do
226− thunkCheckout' <- liftIO $ flip findM (toList thunkCheckoutPaths) $
227− doesPathExist . (thunkDir </>) . _thunkCheckoutPaths_isCheckoutIfExists
228− case thunkCheckout' of
229− Nothing -> fmap ThunkData_Packed <$> readPackedThunk thunkDir
230− Just thunkCheckout -> do
231− origPathExists <- liftIO $ doesDirectoryExist $ _thunkCheckoutPaths_origThunkPath thunkCheckout
232− fmap (Right . ThunkData_Checkout) $ if origPathExists
233− then rightToMaybe <$> readPackedThunk (thunkDir </> _thunkCheckoutPaths_origThunkPath thunkCheckout)
234− else pure Nothing
235−
236203unpackedDirName :: FilePath
237204unpackedDirName = "_"
238205
@@ -241,11 +208,10 @@ attrCacheFileName = ".attr-cache"
241208
242209-- | Specification for how a file in a thunk version works.
243210data ThunkFileSpec
244− = ThunkFileSpec_FileMayExist
245− | ThunkFileSpec_DirMayExist
246− | ThunkFileSpec_AttrCache
247− | ThunkFileSpec_Ptr (LBS.ByteString -> Either String ThunkPtr)
248− | ThunkFileSpec_FileMatches Text
211+ = ThunkFileSpec_Ptr (LBS.ByteString -> Either String ThunkPtr) -- ^ This file specifies a parser for 'ThunkPtr' data
212+ | ThunkFileSpec_FileMatches Text -- ^ This file must match the given content exactly
213+ | ThunkFileSpec_CheckoutIndicator -- ^ Existence of this directory indicates that the thunk is unpacked
214+ | ThunkFileSpec_AttrCache -- ^ This directory is an attribute cache
249215
250216-- | Specification for how a set of files in a thunk version work.
251217data ThunkSpec = ThunkSpec
@@ -262,7 +228,7 @@ matchThunkSpecToDir
262228 => ThunkSpec -- ^ 'ThunkSpec' to match against the given files/directory
263229 -> FilePath -- ^ Path to directory
264230 -> Set FilePath -- ^ Set of file paths relative to the given directory
265− -> m ThunkPtr
231+ -> m ThunkData
266232matchThunkSpecToDir thunkSpec dir dirFiles = do
267233 case nonEmpty (toList $ dirFiles `Set.difference` expectedPaths) of
268234 Just fs -> throwError $ ReadThunkError_UnrecognizedPaths $ (dir </>) <$> fs
@@ -270,12 +236,11 @@ matchThunkSpecToDir thunkSpec dir dirFiles = do
270236 case nonEmpty (toList $ requiredPaths `Set.difference` dirFiles) of
271237 Just fs -> throwError $ ReadThunkError_MissingPaths $ (dir </>) <$> fs
272238 Nothing -> pure ()
273− ptrs <- fmap toList $ flip Map.traverseMaybeWithKey (_thunkSpec_files thunkSpec) $ \expectedPath -> \case
274− ThunkFileSpec_FileMayExist -> liftIO (doesDirectoryExist (dir </> expectedPath)) >>= \case
275− True -> throwError $ ReadThunkError_UnrecognizedPaths $ expectedPath :| []
276− False -> pure Nothing
277− ThunkFileSpec_DirMayExist -> dirMayExist expectedPath
278− ThunkFileSpec_AttrCache -> dirMayExist expectedPath
239+ datas <- fmap toList $ flip Map.traverseMaybeWithKey (_thunkSpec_files thunkSpec) $ \expectedPath -> \case
240+ ThunkFileSpec_AttrCache -> Nothing <$ dirMayExist expectedPath
241+ ThunkFileSpec_CheckoutIndicator -> liftIO (doesDirectoryExist (dir </> expectedPath)) <&> \case
242+ False -> Nothing
243+ True -> Just (ThunkData_Checkout Nothing)
279244 ThunkFileSpec_FileMatches expectedContents -> handle (\(e :: IOError) -> throwError $ ReadThunkError_FileError e) $ do
280245 actualContents <- liftIO (T.readFile $ dir </> expectedPath)
281246 case T.strip expectedContents == T.strip actualContents of
@@ -284,16 +249,19 @@ matchThunkSpecToDir thunkSpec dir dirFiles = do
284249 ThunkFileSpec_Ptr parser -> handle (\(e :: IOError) -> throwError $ ReadThunkError_FileError e) $ do
285250 actualContents <- liftIO $ LBS.readFile $ dir </> expectedPath
286251 case parser actualContents of
287− Right v -> pure $ Just v
252+ Right v -> pure $ Just (ThunkData_Packed (thunkSpec, v))
288253 Left e -> throwError $ ReadThunkError_UnparseablePtr (dir </> expectedPath) e
289254
290− case nubOrd ptrs of
291− [x] -> pure x
292− _ -> throwError ReadThunkError_UnrecognizedThunk
293−
255+ case nonEmpty datas of
256+ Nothing -> throwError ReadThunkError_UnrecognizedThunk
257+ Just xs -> fold1WithM xs $ \a b -> maybe (throwError ReadThunkError_UnrecognizedThunk) pure (mergeThunkData a b)
294258 where
295− expectedPaths = Map.keysSet $ _thunkSpec_files thunkSpec
296− requiredPaths = Map.keysSet $ Map.filter isRequiredFileSpec $ _thunkSpec_files thunkSpec
259+ rootPathsOnly = Set.fromList . mapMaybe takeRootDir . Map.keys
260+ takeRootDir = fmap NonEmpty.head . nonEmpty . splitPath
261+
262+ expectedPaths = rootPathsOnly $ _thunkSpec_files thunkSpec
263+
264+ requiredPaths = rootPathsOnly $ Map.filter isRequiredFileSpec $ _thunkSpec_files thunkSpec
297265 isRequiredFileSpec = \case
298266 ThunkFileSpec_FileMatches _ -> True
299267 ThunkFileSpec_Ptr _ -> True
@@ -301,26 +269,36 @@ matchThunkSpecToDir thunkSpec dir dirFiles = do
301269
302270 dirMayExist expectedPath = liftIO (doesFileExist (dir </> expectedPath)) >>= \case
303271 True -> throwError $ ReadThunkError_UnrecognizedPaths $ expectedPath :| []
304− False -> pure Nothing
272+ False -> pure ()
273+
274+ -- Combine 'ThunkData' from different files, preferring "Checkout" over "Packed"
275+ mergeThunkData a@(ThunkData_Checkout _) (ThunkData_Checkout Nothing) = Just a
276+ mergeThunkData (ThunkData_Checkout Nothing) b@(ThunkData_Checkout _) = Just b
277+ mergeThunkData a@(ThunkData_Checkout (Just _)) (ThunkData_Packed _) = Just a
278+ mergeThunkData (ThunkData_Packed _) b@(ThunkData_Checkout (Just _)) = Just b
279+ mergeThunkData (ThunkData_Packed a) (ThunkData_Checkout Nothing) = Just $ ThunkData_Checkout $ Just a
280+ mergeThunkData (ThunkData_Checkout Nothing) (ThunkData_Packed b) = Just $ ThunkData_Checkout $ Just b
281+ mergeThunkData a@(ThunkData_Checkout (Just (_, ptrA))) (ThunkData_Checkout (Just (_, ptrB))) = if ptrA == ptrB then Just a else Nothing
282+ mergeThunkData a@(ThunkData_Packed (_, ptrA)) (ThunkData_Packed (_, ptrB)) = if ptrA == ptrB then Just a else Nothing
305283
306−readPackedThunkWith
284+ fold1WithM (x :| xs) f = foldM f x xs
285+
286+readThunkWith
307287 :: (MonadObelisk m)
308− => NonEmpty (NonEmpty ThunkSpec) -> FilePath -> m (Either ReadThunkError (ThunkSpec, ThunkPtr))
309−readPackedThunkWith specTypes dir = do
288+ => NonEmpty (NonEmpty ThunkSpec) -> FilePath -> m (Either ReadThunkError ThunkData)
289+readThunkWith specTypes dir = do
310290 dirFiles <- Set.fromList <$> liftIO (listDirectory dir)
311291 let specs = concatMap toList $ toList $ NonEmpty.transpose specTypes -- Interleave spec types so we try each one in a "fair" ordering
312292 flip fix specs $ \loop -> \case
313293 [] -> pure $ Left ReadThunkError_UnrecognizedThunk
314294 spec:rest -> runExceptT (matchThunkSpecToDir spec dir dirFiles) >>= \case
315− Left e -> do
316− putLog Debug [i|Thunk ${_thunkSpec_name spec} specification did not match ${dir}: ${e}|]
317− loop rest
318− Right ptr -> Right (spec, ptr) <$ putLog Debug ("Thunk " <> _thunkSpec_name spec <> " matched " <> T.pack dir)
295+ Left e -> loop rest <* putLog Debug [i|Thunk specification ${_thunkSpec_name spec} did not match ${dir}: ${e}|]
296+ x@(Right _) -> x <$ putLog Debug [i|Thunk specification ${_thunkSpec_name spec} matched ${dir}|]
319297
320298-- | Read a thunk and validate that it is exactly a packed thunk.
321299-- If additional data is present, fail.
322−readPackedThunk :: (MonadObelisk m) => FilePath -> m (Either ReadThunkError (ThunkSpec, ThunkPtr))
323−readPackedThunk = readPackedThunkWith thunkSpecTypes
300+readThunk :: (MonadObelisk m) => FilePath -> m (Either ReadThunkError ThunkData)
301+readThunk = readThunkWith thunkSpecTypes
324302
325303parseThunkPtr :: (Aeson.Object -> Aeson.Parser ThunkSource) -> Aeson.Object -> Aeson.Parser ThunkPtr
326304parseThunkPtr parseSrc v = do
@@ -422,6 +400,21 @@ encodeThunkPtrData (ThunkPtr rev src) = case src of
422400 , confTrailingNewline = True
423401 }
424402
403+-- | Initialize a git repository to an unpacked thunk.
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
413+ liftIO $ do
414+ renameDirectory target (tempThunkDir </> unpackedDirName)
415+ removePathForcibly target
416+ renameDirectory tempThunkDir target
417+
425418createThunk :: MonadObelisk m => FilePath -> ThunkPtr -> m ()
426419createThunk target ptr =
427420 ifor_ (_thunkSpec_files $ thunkPtrToSpec ptr) $ \path -> \case
@@ -444,8 +437,8 @@ createThunkWithLatest target s = do
444437 }
445438
446439updateThunkToLatest :: MonadObelisk m => ThunkUpdateConfig -> FilePath -> m ()
447−updateThunkToLatest (ThunkUpdateConfig mBranch thunkConfig) target = withSpinner' ("Updating thunk " <> T.pack target <> " to latest") (pure $ const $ "Thunk " <> T.pack target <> " updated to latest") $ do
448− checkThunkDirectory "ob thunk update directory cannot be '.'" target
440+updateThunkToLatest (ThunkUpdateConfig mBranch thunkConfig) target = spinner $ do
441+ checkThunkDirectory target
449442 -- check to see if thunk should be updated to a specific branch or just update it's current branch
450443 case mBranch of
451444 Nothing -> do
@@ -469,6 +462,8 @@ updateThunkToLatest (ThunkUpdateConfig mBranch thunkConfig) target = withSpinner
469462 let tsg = forgetGithub False tsgh
470463 setThunk thunkConfig target tsg branch
471464 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."
465+ where
466+ spinner = withSpinner' ("Updating thunk " <> T.pack target <> " to latest") (pure $ const $ "Thunk " <> T.pack target <> " updated to latest")
472467
473468setThunk :: MonadObelisk m => ThunkConfig -> FilePath -> GitSource -> String -> m ()
474469setThunk thunkConfig target gs branch = do
@@ -539,6 +534,7 @@ legacyGitHubThunkSpec name loader = ThunkSpec name $ Map.fromList
539534 [ ("default.nix", ThunkFileSpec_FileMatches $ T.strip loader)
540535 , ("github.json" , ThunkFileSpec_Ptr parseGitHubJsonBytes)
541536 , (attrCacheFileName, ThunkFileSpec_AttrCache)
537+ , (".git", ThunkFileSpec_CheckoutIndicator)
542538 ]
543539
544540gitHubThunkSpecV5 :: ThunkSpec
@@ -624,6 +620,7 @@ legacyGitThunkSpec name loader = ThunkSpec name $ Map.fromList
624620 [ ("default.nix", ThunkFileSpec_FileMatches $ T.strip loader)
625621 , ("git.json" , ThunkFileSpec_Ptr parseGitJsonBytes)
626622 , (attrCacheFileName, ThunkFileSpec_AttrCache)
623+ , (".git", ThunkFileSpec_CheckoutIndicator)
627624 ]
628625
629626gitThunkSpecV5 :: ThunkSpec
@@ -652,6 +649,7 @@ mkThunkSpec name jsonFileName parser srcNix = ThunkSpec name $ Map.fromList
652649 , ("src.nix", ThunkFileSpec_FileMatches srcNix)
653650 , (jsonFileName, ThunkFileSpec_Ptr parser)
654651 , (attrCacheFileName, ThunkFileSpec_AttrCache)
652+ , (unpackedDirName, ThunkFileSpec_CheckoutIndicator)
655653 ]
656654 where
657655 defaultNixViaSrc = [here|
@@ -769,14 +767,21 @@ unpackThunk :: MonadObelisk m => FilePath -> m ()
769767unpackThunk = unpackThunk' False
770768
771769-- | Check that we are not somewhere inside the thunk directory
772−checkThunkDirectory :: MonadObelisk m => Text -> FilePath -> m ()
773−checkThunkDirectory msg thunkDir = do
770+checkThunkDirectory :: MonadObelisk m => FilePath -> m ()
771+checkThunkDirectory thunkDir = do
774772 currentDir <- liftIO getCurrentDirectory
775773 thunkDir' <- liftIO $ canonicalizePath thunkDir
776− when (thunkDir' `L.isInfixOf` currentDir) $ failWith msg
774+ when (thunkDir' `L.isInfixOf` currentDir) $
775+ failWith [i|Can't perform thunk operations from within the thunk directory: ${thunkDir}|]
776+
777+ -- Don't let thunk commands work when directly given an unpacked repo
778+ when (takeFileName thunkDir == unpackedDirName) $
779+ readThunk (takeDirectory thunkDir) >>= \case
780+ Right _ -> failWith [i|Refusing to perform thunk operation on ${thunkDir} because it is a thunk's unpacked source|]
781+ Left _ -> pure ()
777782
778783unpackThunk' :: MonadObelisk m => Bool -> FilePath -> m ()
779−unpackThunk' noTrail thunkDir = checkThunkDirectory "Can't pack/unpack from within the thunk directory" thunkDir >> readThunk thunkDir >>= \case
784+unpackThunk' noTrail thunkDir = checkThunkDirectory thunkDir *> readThunk thunkDir >>= \case
780785 Left err -> failWith [i|Invalid thunk at ${thunkDir}: ${err}|]
781786 --TODO: Overwrite option that rechecks out thunk; force option to do so even if working directory is dirty
782787 Right (ThunkData_Checkout _) -> failWith [i|Thunk at ${thunkDir} is already unpacked|]
@@ -808,7 +813,7 @@ packThunk :: MonadObelisk m => ThunkPackConfig -> FilePath -> m ThunkPtr
808813packThunk = packThunk' False
809814
810815packThunk' :: 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
816+packThunk' noTrail (ThunkPackConfig force thunkConfig) thunkDir = checkThunkDirectory thunkDir *> readThunk thunkDir >>= \case
812817 Left err -> failWith [i|Can't pack thunk at ${thunkDir}: ${err}|]
813818 Right (ThunkData_Packed _) -> failWith [i|Thunk at ${thunkDir} is is already packed|]
814819 Right (ThunkData_Checkout _) -> do
@@ -839,14 +844,13 @@ getThunkPtr checkClean dir mPrivate = do
839844 "thunk pack: thunk checkout contains unsaved modifications"
840845
841846 -- Check whether there are any stashes
842− stashOutput <- readGitProcess thunkDir ["stash", "list"]
843− when checkClean $ case T.null stashOutput of
844− False -> do
847+ when checkClean $ do
848+ stashOutput <- readGitProcess thunkDir ["stash", "list"]
849+ unless (T.null stashOutput) $
845850 failWith $ T.unlines $
846851 [ "thunk pack: thunk checkout has stashes"
847852 , "git stash list:"
848853 ] ++ T.lines stashOutput
849− True -> return ()
850854
851855 -- Get current branch
852856 (mCurrentBranch, mCurrentCommit) <- do
@@ -932,8 +936,9 @@ getThunkPtr checkClean dir mPrivate = do
932936 \pushed but this repo's remote tracking branches don't know it.)"
933937 ]
934938
935− -- We assume it's safe to pack the thunk at this point
936− putLog Informational "All changes safe in git remotes. OK to pack thunk."
939+ when checkClean $ do
940+ -- We assume it's safe to pack the thunk at this point
941+ putLog Informational "All changes safe in git remotes. OK to pack thunk."
937942
938943 let remote = maybe "origin" snd $ flip Map.lookup headUpstream =<< mCurrentBranch
939944