@@ -5,43 +5,17 @@
55{-# LANGUAGE MultiWayIf #-}
66{-# LANGUAGE OverloadedStrings #-}
77{-# LANGUAGE PatternGuards #-}
8+{-# LANGUAGE QuasiQuotes #-}
89{-# LANGUAGE ScopedTypeVariables #-}
910{-# LANGUAGE TypeApplications #-}
10−module Obelisk.Command.Thunk
11− ( GitHubSource (..)
12− , GitUri (..)
13− , ReadThunkError (..)
14− , ThunkConfig (..)
15− , ThunkData (..)
16− , ThunkPackConfig (..)
17− , ThunkPtr (..)
18− , ThunkRev (..)
19− , ThunkSource (..)
20− , ThunkUpdateConfig (..)
21− , attrCacheFileName
22− , createThunk
23− , createThunkWithLatest
24− , getLatestRev
25− , getThunkGitBranch
26− , getThunkPtr
27− , gitUriToText
28− , nixBuildAttrWithCache
29− , nixBuildThunkAttrWithCache
30− , packThunk
31− , parseGitUri
32− , readThunk
33− , unpackThunk
34− , updateThunk
35− , updateThunkToLatest
36− , uriThunkPtr
37− ) where
11+module Obelisk.Command.Thunk where
3812
3913import Control.Applicative
4014import Control.Exception (displayException, try)
41−import qualified Control.Lens as Lens
42−import Control.Lens.Indexed hiding ((<.>))
15+import Control.Lens (ifor, ifor_, (.~))
4316import Control.Monad
44−import Control.Monad.Catch (handle)
17+import Control.Monad.Extra (findM, unlessM, whenM)
18+import Control.Monad.Catch (MonadCatch, handle)
4519import Control.Monad.Except
4620import Data.Aeson ((.=))
4721import qualified Data.Aeson as Aeson
@@ -51,21 +25,27 @@ import qualified Data.ByteString.Lazy as LBS
5125import Data.Containers.ListUtils (nubOrd)
5226import Data.Default
5327import Data.Either.Combinators (fromRight', rightToMaybe)
28+import Data.Foldable (toList)
29+import Data.Function ((&))
30+import Data.Functor ((<&>))
5431import Data.Git.Ref (Ref)
5532import qualified Data.Git.Ref as Ref
5633import qualified Data.List as L
57−import Data.List.NonEmpty (NonEmpty (..))
34+import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
5835import qualified Data.List.NonEmpty as NonEmpty
5936import Data.Map (Map)
6037import qualified Data.Map as Map
6138import Data.Maybe
6239import Data.Set (Set)
6340import qualified Data.Set as Set
41+import Data.String.Here.Interpolated (i)
42+import Data.String.Here.Uninterpolated (here)
6443import Data.Text (Text)
6544import qualified Data.Text as T
6645import Data.Text.Encoding
6746import qualified Data.Text.IO as T
6847import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
48+import Data.Traversable (for)
6949import Data.Yaml (parseMaybe)
7050import GitHub
7151import GitHub.Data.Name
@@ -84,11 +64,10 @@ import Obelisk.Command.Utils
8464
8565--TODO: Support symlinked thunk data
8666data ThunkData
87− = ThunkData_Packed ThunkPtr
67+ = ThunkData_Packed ThunkSpec ThunkPtr
8868 -- ^ Packed thunk
89− | ThunkData_Checkout (Maybe ThunkPtr)
69+ | ThunkData_Checkout
9070 -- ^ Checked out thunk that was unpacked from this pointer
91− deriving (Show, Eq, Ord)
9271
9372-- | A reference to the exact data that a thunk should translate into
9473data ThunkPtr = ThunkPtr
@@ -213,96 +192,117 @@ nixPrefetchGit uri rev fetchSubmodules =
213192
214193--TODO: Pretty print these
215194data ReadThunkError
216− = ReadThunkError_UnrecognizedFiles
217− | ReadThunkError_AmbiguousFiles
218− | ReadThunkError_UnrecognizedLoader Text
219− | ReadThunkError_UnparseablePtr LBS.ByteString
220− deriving (Show)
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− files <- liftIO $ listDirectory thunkDir
227− case ".git" `elem` files of
228− True -> fmap ThunkData_Checkout <$> do
229− let origThunkPath = thunkDir </> ".git" </> "obelisk" </> "orig-thunk"
230− liftIO $ doesDirectoryExist origThunkPath >>= \case
231− True -> fmap Just <$> readPackedThunk origThunkPath
232− False -> return $ return Nothing
233− False -> liftIO $ fmap ThunkData_Packed <$> readPackedThunk thunkDir
195+ = ReadThunkError_UnrecognizedThunk
196+ | ReadThunkError_UnrecognizedPaths (NonEmpty FilePath)
197+ | ReadThunkError_MissingPaths (NonEmpty FilePath)
198+ | ReadThunkError_UnparseablePtr FilePath String
199+ | ReadThunkError_FileError IOError
200+ | ReadThunkError_FileDoesNotMatch FilePath Text
201+ | ReadThunkError_UnrecognizedState String
202+ | ReadThunkError_AmbiguousPackedState ThunkPtr ThunkPtr
203+ deriving (Show)
204+
205+unpackedDirName :: FilePath
206+unpackedDirName = "local"
234207
235208attrCacheFileName :: FilePath
236209attrCacheFileName = ".attr-cache"
237210
238−data ThunkType = ThunkType
239− { _thunkType_loader :: FilePath
240− , _thunkType_json :: FilePath
241− , _thunkType_optional :: Set FilePath
242− , _thunkType_loaderVersions :: NonEmpty Text
243− , _thunkType_parser :: Aeson.Object -> Aeson.Parser ThunkPtr
244− }
245−
246−gitHubThunkType :: ThunkType
247−gitHubThunkType = ThunkType
248− { _thunkType_loader = "default.nix"
249− , _thunkType_json = "github.json"
250− , _thunkType_optional = Set.fromList [attrCacheFileName]
251− , _thunkType_loaderVersions = gitHubStandaloneLoaders
252− , _thunkType_parser = parseThunkPtr $ \v ->
253− ThunkSource_GitHub <$> parseGitHubSource v <|> ThunkSource_Git <$> parseGitSource v
254− }
255−
256−gitThunkType :: ThunkType
257−gitThunkType = ThunkType
258− { _thunkType_loader = "default.nix"
259− , _thunkType_json = "git.json"
260− , _thunkType_optional = Set.fromList [attrCacheFileName]
261− , _thunkType_loaderVersions = plainGitStandaloneLoaders
262− , _thunkType_parser = parseThunkPtr $ fmap ThunkSource_Git . parseGitSource
211+-- | Specification for how a file in a thunk version works.
212+data ThunkFileSpec
213+ = ThunkFileSpec_Ptr (LBS.ByteString -> Either String ThunkPtr) -- ^ This file specifies 'ThunkPtr' data
214+ | ThunkFileSpec_FileMatches Text -- ^ This file must match the given content exactly
215+ | ThunkFileSpec_CheckoutIndicator -- ^ Existence of this directory indicates that the thunk is unpacked
216+ | ThunkFileSpec_AttrCache -- ^ This directory is an attribute cache
217+
218+-- | Specification for how a set of files in a thunk version work.
219+data ThunkSpec = ThunkSpec
220+ { _thunkSpec_name :: !Text
221+ , _thunkSpec_files :: !(Map FilePath ThunkFileSpec)
263222 }
264223
265−thunkTypes :: [ThunkType]
266−thunkTypes = [gitThunkType, gitHubThunkType]
267−
268−findThunkType :: [ThunkType] -> FilePath -> IO (Either ReadThunkError ThunkType)
269−findThunkType types thunkDir = do
270− matches <- fmap catMaybes $ forM types $ \thunkType -> do
271− let
272− expectedContents = Set.fromList $ (thunkDir </>) <$>
273− [ _thunkType_loader thunkType
274− , _thunkType_json thunkType
275− ]
276− optionalContents = Set.map (thunkDir </>) (_thunkType_optional thunkType)
277−
278− -- Ensure that there aren't any other files in the thunk
279− -- NB: System.Directory.listDirectory returns the contents without the directory path
280− files <- liftIO $ Set.fromList . fmap (thunkDir </>) <$> listDirectory thunkDir
281− let unexpectedContents = files `Set.difference` (expectedContents `Set.union` optionalContents)
282− missingContents = expectedContents `Set.difference` files
283− pure $ if Set.null unexpectedContents && Set.null missingContents
284− then Just thunkType
285− else Nothing
286−
287− pure $ case matches of
288− [singleMatch] -> Right singleMatch
289− [] -> Left ReadThunkError_UnrecognizedFiles
290− _ -> Left ReadThunkError_AmbiguousFiles
224+thunkSpecTypes :: NonEmpty (NonEmpty ThunkSpec)
225+thunkSpecTypes = gitThunkSpecs :| [gitHubThunkSpecs]
226+
227+-- | Attempts to match a 'ThunkSpec' to a given directory.
228+matchThunkSpecToDir
229+ :: (MonadError ReadThunkError m, MonadIO m, MonadCatch m)
230+ => ThunkSpec -- ^ 'ThunkSpec' to match against the given files/directory
231+ -> FilePath -- ^ Path to directory
232+ -> Set FilePath -- ^ Set of file paths relative to the given directory
233+ -> m ThunkData
234+matchThunkSpecToDir thunkSpec dir dirFiles = do
235+ case nonEmpty (toList $ dirFiles `Set.difference` expectedPaths) of
236+ Just fs -> throwError $ ReadThunkError_UnrecognizedPaths $ (dir </>) <$> fs
237+ Nothing -> pure ()
238+ case nonEmpty (toList $ requiredPaths `Set.difference` dirFiles) of
239+ Just fs -> throwError $ ReadThunkError_MissingPaths $ (dir </>) <$> fs
240+ Nothing -> pure ()
241+ datas <- fmap toList $ flip Map.traverseMaybeWithKey (_thunkSpec_files thunkSpec) $ \expectedPath -> \case
242+ ThunkFileSpec_AttrCache -> Nothing <$ dirMayExist expectedPath
243+ ThunkFileSpec_CheckoutIndicator -> liftIO (doesDirectoryExist (dir </> expectedPath)) <&> \case
244+ False -> Nothing
245+ True -> Just ThunkData_Checkout
246+ ThunkFileSpec_FileMatches expectedContents -> handle (\(e :: IOError) -> throwError $ ReadThunkError_FileError e) $ do
247+ actualContents <- liftIO (T.readFile $ dir </> expectedPath)
248+ case T.strip expectedContents == T.strip actualContents of
249+ True -> pure Nothing
250+ False -> throwError $ ReadThunkError_FileDoesNotMatch (dir </> expectedPath) expectedContents
251+ ThunkFileSpec_Ptr parser -> handle (\(e :: IOError) -> throwError $ ReadThunkError_FileError e) $ do
252+ let path = dir </> expectedPath
253+ liftIO (doesFileExist path) >>= \case
254+ False -> pure Nothing
255+ True -> do
256+ actualContents <- liftIO $ LBS.readFile path
257+ case parser actualContents of
258+ Right v -> pure $ Just (ThunkData_Packed thunkSpec v)
259+ Left e -> throwError $ ReadThunkError_UnparseablePtr (dir </> expectedPath) e
260+
261+ case nonEmpty datas of
262+ Nothing -> throwError ReadThunkError_UnrecognizedThunk
263+ Just xs -> fold1WithM xs $ \a b -> either throwError pure (mergeThunkData a b)
264+ where
265+ rootPathsOnly = Set.fromList . mapMaybe takeRootDir . Map.keys
266+ takeRootDir = fmap NonEmpty.head . nonEmpty . splitPath
267+
268+ expectedPaths = rootPathsOnly $ _thunkSpec_files thunkSpec
269+
270+ requiredPaths = rootPathsOnly $ Map.filter isRequiredFileSpec $ _thunkSpec_files thunkSpec
271+ isRequiredFileSpec = \case
272+ ThunkFileSpec_FileMatches _ -> True
273+ _ -> False
274+
275+ dirMayExist expectedPath = liftIO (doesFileExist (dir </> expectedPath)) >>= \case
276+ True -> throwError $ ReadThunkError_UnrecognizedPaths $ expectedPath :| []
277+ False -> pure ()
278+
279+ -- Combine 'ThunkData' from different files, preferring "Checkout" over "Packed"
280+ mergeThunkData ThunkData_Checkout ThunkData_Checkout = Right ThunkData_Checkout
281+ mergeThunkData ThunkData_Checkout ThunkData_Packed{} = Left bothPackedAndUnpacked
282+ mergeThunkData ThunkData_Packed{} ThunkData_Checkout = Left bothPackedAndUnpacked
283+ mergeThunkData a@(ThunkData_Packed _ ptrA) (ThunkData_Packed _ ptrB) =
284+ if ptrA == ptrB then Right a else Left $ ReadThunkError_AmbiguousPackedState ptrA ptrB
285+
286+ bothPackedAndUnpacked = ReadThunkError_UnrecognizedState "Both packed data and checkout present"
287+
288+ fold1WithM (x :| xs) f = foldM f x xs
289+
290+readThunkWith
291+ :: (MonadObelisk m)
292+ => NonEmpty (NonEmpty ThunkSpec) -> FilePath -> m (Either ReadThunkError ThunkData)
293+readThunkWith specTypes dir = do
294+ dirFiles <- Set.fromList <$> liftIO (listDirectory dir)
295+ let specs = concatMap toList $ toList $ NonEmpty.transpose specTypes -- Interleave spec types so we try each one in a "fair" ordering
296+ flip fix specs $ \loop -> \case
297+ [] -> pure $ Left ReadThunkError_UnrecognizedThunk
298+ spec:rest -> runExceptT (matchThunkSpecToDir spec dir dirFiles) >>= \case
299+ Left e -> putLog Debug [i|Thunk specification ${_thunkSpec_name spec} did not match ${dir}: ${e}|] *> loop rest
300+ x@(Right _) -> x <$ putLog Debug [i|Thunk specification ${_thunkSpec_name spec} matched ${dir}|]
291301
292302-- | Read a thunk and validate that it is exactly a packed thunk.
293303-- If additional data is present, fail.
294−readPackedThunk :: FilePath -> IO (Either ReadThunkError ThunkPtr)
295−readPackedThunk thunkDir = runExceptT $ do
296− thunkType <- ExceptT $ findThunkType thunkTypes thunkDir
297− -- Ensure that we recognize the thunk loader
298− loader <- liftIO $ T.readFile $ thunkDir </> _thunkType_loader thunkType
299− unless (loader `elem` _thunkType_loaderVersions thunkType) $ do
300− throwError $ ReadThunkError_UnrecognizedLoader loader
301−
302− txt <- liftIO $ LBS.readFile $ thunkDir </> _thunkType_json thunkType
303− case parseMaybe (_thunkType_parser thunkType) =<< Aeson.decode txt of
304− Nothing -> throwError $ ReadThunkError_UnparseablePtr txt
305− Just ptr -> return ptr
304+readThunk :: (MonadObelisk m) => FilePath -> m (Either ReadThunkError ThunkData)
305+readThunk = readThunkWith thunkSpecTypes
306306
307307parseThunkPtr :: (Aeson.Object -> Aeson.Parser ThunkSource) -> Aeson.Object -> Aeson.Parser ThunkPtr
308308parseThunkPtr parseSrc v = do
@@ -346,16 +346,18 @@ parseGitSource v = do
346346overwriteThunk :: MonadObelisk m => FilePath -> ThunkPtr -> m ()
347347overwriteThunk target thunk = do
348348 -- Ensure that this directory is a valid thunk (i.e. so we aren't losing any data)
349− Right _ <- readThunk target
349+ readThunk target >>= \case
350+ Left e -> failWith [i|Invalid thunk at ${target}: ${e}|]
351+ Right _ -> pure ()
350352
351353 --TODO: Is there a safer way to do this overwriting?
352− liftIO $ removeDirectoryRecursive target
353− liftIO $ createThunk target thunk
354+ callProcessAndLogOutput (Debug, Error) $ proc rmPath ["-r", target] -- target may be a symlink
355+ createThunk target $ Right thunk
354356
355−thunkPtrLoader :: ThunkPtr -> Text
356−thunkPtrLoader thunk = case _thunkPtr_source thunk of
357− ThunkSource_GitHub _ -> NonEmpty.head gitHubStandaloneLoaders
358− ThunkSource_Git _ -> NonEmpty.head plainGitStandaloneLoaders
357+thunkPtrToSpec :: ThunkPtr -> ThunkSpec
358+thunkPtrToSpec thunk = case _thunkPtr_source thunk of
359+ ThunkSource_GitHub _ -> NonEmpty.head gitHubThunkSpecs
360+ ThunkSource_Git _ -> NonEmpty.head gitThunkSpecs
359361
360362-- It's important that formatting be very consistent here, because
361363-- otherwise when people update thunks, their patches will be messy
@@ -402,35 +404,56 @@ encodeThunkPtrData (ThunkPtr rev src) = case src of
402404 , confTrailingNewline = True
403405 }
404406
405−createThunk :: MonadIO m => FilePath -> ThunkPtr -> m ()
406−createThunk target thunk = liftIO $ do
407− createDirectoryIfMissing True (target </> attrCacheFileName)
408− T.writeFile (target </> "default.nix") (thunkPtrLoader thunk)
409− let
410− jsonFileName = case _thunkPtr_source thunk of
411− ThunkSource_GitHub _ -> "github"
412− ThunkSource_Git _ -> "git"
413− LBS.writeFile (target </> jsonFileName <.> "json") (encodeThunkPtrData thunk)
407+-- | Initialize a git repository to an unpacked thunk.
408+initThunk :: MonadObelisk m => FilePath -> m ()
409+initThunk target = withSpinner [i|Initializing thunk at ${target}|] $ do
410+ checkThunkDirectory target
411+ unlessM (liftIO $ doesDirectoryExist $ target </> ".git") $ failWith [i|${target} is not a git checkout.|]
412+ ptr <- getThunkPtr False target Nothing
413+ let tempThunkDir = target <.> "thunk-init"
414+ whenM (liftIO $ doesPathExist tempThunkDir) $
415+ failWith [i|A previous 'thunk init' left unfinished state at ${tempThunkDir}. You will need to rename or remove that path before trying again.|]
416+ createThunk tempThunkDir $ Left (thunkPtrToSpec ptr) -- Only write the skeleton, but skip the ptr itself since it's unpacked
417+ liftIO $ do
418+ renameDirectory target (tempThunkDir </> unpackedDirName)
419+ removePathForcibly target
420+ renameDirectory tempThunkDir target
421+
422+createThunk :: MonadObelisk m => FilePath -> Either ThunkSpec ThunkPtr -> m ()
423+createThunk target ptrInfo =
424+ ifor_ (_thunkSpec_files spec) $ \path -> \case
425+ ThunkFileSpec_FileMatches content -> withReadyPath path $ \p -> liftIO $ T.writeFile p content
426+ ThunkFileSpec_Ptr _ -> case ptrInfo of
427+ Left _ -> pure () -- We can't write the ptr without it
428+ Right ptr -> withReadyPath path $ \p -> liftIO $ LBS.writeFile p (encodeThunkPtrData ptr)
429+ _ -> pure ()
430+ where
431+ spec = either id thunkPtrToSpec ptrInfo
432+ withReadyPath path f = do
433+ let fullPath = target </> path
434+ putLog Debug $ "Writing thunk file " <> T.pack fullPath
435+ liftIO $ createDirectoryIfMissing True $ takeDirectory fullPath
436+ f fullPath
414437
415438createThunkWithLatest :: MonadObelisk m => FilePath -> ThunkSource -> m ()
416439createThunkWithLatest target s = do
417440 rev <- getLatestRev s
418− createThunk target $ ThunkPtr
441+ createThunk target $ Right $ ThunkPtr
419442 { _thunkPtr_source = s
420443 , _thunkPtr_rev = rev
421444 }
422445
423446updateThunkToLatest :: MonadObelisk m => ThunkUpdateConfig -> FilePath -> m ()
424−updateThunkToLatest (ThunkUpdateConfig mBranch thunkConfig) target = withSpinner' ("Updating thunk " <> T.pack target <> " to latest") (pure $ const $ "Thunk " <> T.pack target <> " updated to latest") $ do
425− checkThunkDirectory "ob thunk update directory cannot be '.'" target
447+updateThunkToLatest (ThunkUpdateConfig mBranch thunkConfig) target = spinner $ do
448+ checkThunkDirectory target
426449 -- check to see if thunk should be updated to a specific branch or just update it's current branch
427450 case mBranch of
428451 Nothing -> do
429452 (overwrite, ptr) <- readThunk target >>= \case
430− Left err -> failWith $ T.pack $ "thunk update: " <> show err
453+ Left err -> failWith [i|Thunk update: ${err}|]
431454 Right c -> case c of
432− ThunkData_Packed t -> return (target, t)
433− ThunkData_Checkout _ -> failWith "cannot update an unpacked thunk"
455+ ThunkData_Packed _ t -> return (target, t)
456+ ThunkData_Checkout -> failWith "cannot update an unpacked thunk"
434457 let src = _thunkPtr_source ptr
435458 rev <- getLatestRev src
436459 overwriteThunk overwrite $ modifyThunkPtrByConfig thunkConfig $ ThunkPtr
@@ -438,14 +461,16 @@ updateThunkToLatest (ThunkUpdateConfig mBranch thunkConfig) target = withSpinner
438461 , _thunkPtr_rev = rev
439462 }
440463 Just branch -> readThunk target >>= \case
441− Left err -> failWith $ T.pack $ "thunk update: " <> show err
464+ Left err -> failWith [i|Thunk update: ${err}|]
442465 Right c -> case c of
443− ThunkData_Packed t -> case _thunkPtr_source t of
466+ ThunkData_Packed _ t -> case _thunkPtr_source t of
444467 ThunkSource_Git tsg -> setThunk thunkConfig target tsg branch
445468 ThunkSource_GitHub tsgh -> do
446469 let tsg = forgetGithub False tsgh
447470 setThunk thunkConfig target tsg branch
448− 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."
471+ 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.|]
472+ where
473+ spinner = withSpinner' ("Updating thunk " <> T.pack target <> " to latest") (pure $ const $ "Thunk " <> T.pack target <> " updated to latest")
449474
450475setThunk :: MonadObelisk m => ThunkConfig -> FilePath -> GitSource -> String -> m ()
451476setThunk thunkConfig target gs branch = do
@@ -455,21 +480,21 @@ setThunk thunkConfig target gs branch = do
455480
456481-- | All recognized github standalone loaders, ordered from newest to oldest.
457482-- This tool will only ever produce the newest one when it writes a thunk.
458−gitHubStandaloneLoaders :: NonEmpty Text
459−gitHubStandaloneLoaders =
460− gitHubStandaloneLoaderV4 :|
461− [ gitHubStandaloneLoaderV3
462− , gitHubStandaloneLoaderV2
463− , gitHubStandaloneLoaderV1
483+gitHubThunkSpecs :: NonEmpty ThunkSpec
484+gitHubThunkSpecs =
485+ gitHubThunkSpecV5 :|
486+ [ gitHubThunkSpecV4
487+ , gitHubThunkSpecV3
488+ , gitHubThunkSpecV2
489+ , gitHubThunkSpecV1
464490 ]
465491
466−gitHubStandaloneLoaderV1 :: Text
467−gitHubStandaloneLoaderV1 = T.unlines
468− [ "import ((import <nixpkgs> {}).fetchFromGitHub (builtins.fromJSON (builtins.readFile ./github.json)))"
469− ]
492+gitHubThunkSpecV1 :: ThunkSpec
493+gitHubThunkSpecV1 = legacyGitHubThunkSpec "github-v1"
494+ "import ((import <nixpkgs> {}).fetchFromGitHub (builtins.fromJSON (builtins.readFile ./github.json)))"
470495
471−gitHubStandaloneLoaderV2 :: Text
472−gitHubStandaloneLoaderV2 = T.unlines
496+gitHubThunkSpecV2 :: ThunkSpec
497+gitHubThunkSpecV2 = legacyGitHubThunkSpec "github-v2" $ T.unlines
473498 [ "# DO NOT HAND-EDIT THIS FILE" --TODO: Add something about how to get more info on Obelisk, etc.
474499 , "import ((import <nixpkgs> {}).fetchFromGitHub ("
475500 , " let json = builtins.fromJSON (builtins.readFile ./github.json);"
@@ -479,8 +504,8 @@ gitHubStandaloneLoaderV2 = T.unlines
479504 , "))"
480505 ]
481506
482−gitHubStandaloneLoaderV3 :: Text
483−gitHubStandaloneLoaderV3 = T.unlines
507+gitHubThunkSpecV3 :: ThunkSpec
508+gitHubThunkSpecV3 = legacyGitHubThunkSpec "github-v3" $ T.unlines
484509 [ "# DO NOT HAND-EDIT THIS FILE"
485510 , "let"
486511 , " fetch = { private ? false, ... }@args: if private && builtins.hasAttr \"fetchGit\" builtins"
@@ -499,8 +524,8 @@ gitHubStandaloneLoaderV3 = T.unlines
499524 , "in import (fetch (builtins.fromJSON (builtins.readFile ./github.json)))"
500525 ]
501526
502−gitHubStandaloneLoaderV4 :: Text
503−gitHubStandaloneLoaderV4 = T.unlines
527+gitHubThunkSpecV4 :: ThunkSpec
528+gitHubThunkSpecV4 = legacyGitHubThunkSpec "github-v4" $ T.unlines
504529 [ "# DO NOT HAND-EDIT THIS FILE"
505530 , "let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }:"
506531 , " if !fetchSubmodules && !private then builtins.fetchTarball {"
@@ -511,24 +536,50 @@ gitHubStandaloneLoaderV4 = T.unlines
511536 , "in import (fetch (builtins.fromJSON (builtins.readFile ./github.json)))"
512537 ]
513538
514−plainGitStandaloneLoaders :: NonEmpty Text
515−plainGitStandaloneLoaders =
516− plainGitStandaloneLoaderV4 :|
517− [ plainGitStandaloneLoaderV1
518− , plainGitStandaloneLoaderV2
519− , plainGitStandaloneLoaderV3
539+legacyGitHubThunkSpec :: Text -> Text -> ThunkSpec
540+legacyGitHubThunkSpec name loader = ThunkSpec name $ Map.fromList
541+ [ ("default.nix", ThunkFileSpec_FileMatches $ T.strip loader)
542+ , ("github.json" , ThunkFileSpec_Ptr parseGitHubJsonBytes)
543+ , (attrCacheFileName, ThunkFileSpec_AttrCache)
544+ , (".git", ThunkFileSpec_CheckoutIndicator)
520545 ]
521546
522−plainGitStandaloneLoaderV1 :: Text
523−plainGitStandaloneLoaderV1 = T.unlines
547+gitHubThunkSpecV5 :: ThunkSpec
548+gitHubThunkSpecV5 = mkThunkSpec "github-v5" "github.json" parseGitHubJsonBytes [here|
549+# DO NOT HAND-EDIT THIS FILE
550+let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }:
551+ if !fetchSubmodules && !private then builtins.fetchTarball {
552+ url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256;
553+ } else (import <nixpkgs> {}).fetchFromGitHub {
554+ inherit owner repo rev sha256 fetchSubmodules private;
555+ };
556+ json = builtins.fromJSON (builtins.readFile ./github.json);
557+in if builtins.pathExists ./local then ./local else fetch json
558+|]
559+
560+parseGitHubJsonBytes :: LBS.ByteString -> Either String ThunkPtr
561+parseGitHubJsonBytes = parseJsonObject $ parseThunkPtr $ \v ->
562+ ThunkSource_GitHub <$> parseGitHubSource v <|> ThunkSource_Git <$> parseGitSource v
563+
564+gitThunkSpecs :: NonEmpty ThunkSpec
565+gitThunkSpecs =
566+ gitThunkSpecV5 :|
567+ [ gitThunkSpecV4
568+ , gitThunkSpecV3
569+ , gitThunkSpecV2
570+ , gitThunkSpecV1
571+ ]
572+
573+gitThunkSpecV1 :: ThunkSpec
574+gitThunkSpecV1 = legacyGitThunkSpec "git-v1" $ T.unlines
524575 [ "# DO NOT HAND-EDIT THIS FILE"
525576 , "let fetchGit = {url, rev, ref ? null, branch ? null, sha256 ? null, fetchSubmodules ? null}:"
526577 , " assert !fetchSubmodules; (import <nixpkgs> {}).fetchgit { inherit url rev sha256; };"
527578 , "in import (fetchGit (builtins.fromJSON (builtins.readFile ./git.json)))"
528579 ]
529580
530−plainGitStandaloneLoaderV2 :: Text
531−plainGitStandaloneLoaderV2 = T.unlines
581+gitThunkSpecV2 :: ThunkSpec
582+gitThunkSpecV2 = legacyGitThunkSpec "git-v2" $ T.unlines
532583 [ "# DO NOT HAND-EDIT THIS FILE"
533584 , "let fetchGit = {url, rev, ref ? null, branch ? null, sha256 ? null, fetchSubmodules ? null}:"
534585 , " if builtins.hasAttr \"fetchGit\" builtins"
@@ -539,8 +590,8 @@ plainGitStandaloneLoaderV2 = T.unlines
539590
540591-- This loader has a bug because @builtins.fetchGit@ is not given a @ref@
541592-- and will fail to find commits without this because it does shallow clones.
542−plainGitStandaloneLoaderV3 :: Text
543−plainGitStandaloneLoaderV3 = T.unlines
593+gitThunkSpecV3 :: ThunkSpec
594+gitThunkSpecV3 = legacyGitThunkSpec "git-v3" $ T.unlines
544595 [ "# DO NOT HAND-EDIT THIS FILE"
545596 , "let fetch = {url, rev, ref ? null, sha256 ? null, fetchSubmodules ? false, private ? false, ...}:"
546597 , " let realUrl = let firstChar = builtins.substring 0 1 url; in"
@@ -555,8 +606,8 @@ plainGitStandaloneLoaderV3 = T.unlines
555606 , "in import (fetch (builtins.fromJSON (builtins.readFile ./git.json)))"
556607 ]
557608
558−plainGitStandaloneLoaderV4 :: Text
559−plainGitStandaloneLoaderV4 = T.unlines
609+gitThunkSpecV4 :: ThunkSpec
610+gitThunkSpecV4 = legacyGitThunkSpec "git-v4" $ T.unlines
560611 [ "# DO NOT HAND-EDIT THIS FILE"
561612 , "let fetch = {url, rev, branch ? null, sha256 ? null, fetchSubmodules ? false, private ? false, ...}:"
562613 , " let realUrl = let firstChar = builtins.substring 0 1 url; in"
@@ -572,10 +623,52 @@ plainGitStandaloneLoaderV4 = T.unlines
572623 , "in import (fetch (builtins.fromJSON (builtins.readFile ./git.json)))"
573624 ]
574625
575−thunkFileNames :: [FilePath]
576−thunkFileNames = ["default.nix", "github.json", "git.json"]
626+legacyGitThunkSpec :: Text -> Text -> ThunkSpec
627+legacyGitThunkSpec name loader = ThunkSpec name $ Map.fromList
628+ [ ("default.nix", ThunkFileSpec_FileMatches $ T.strip loader)
629+ , ("git.json" , ThunkFileSpec_Ptr parseGitJsonBytes)
630+ , (attrCacheFileName, ThunkFileSpec_AttrCache)
631+ , (".git", ThunkFileSpec_CheckoutIndicator)
632+ ]
577633
578−--TODO: when checking something out, make a shallow clone
634+gitThunkSpecV5 :: ThunkSpec
635+gitThunkSpecV5 = mkThunkSpec "git-v5" "git.json" parseGitJsonBytes [here|
636+# DO NOT HAND-EDIT THIS FILE
637+let fetch = {url, rev, branch ? null, sha256 ? null, fetchSubmodules ? false, private ? false, ...}:
638+ let realUrl = let firstChar = builtins.substring 0 1 url; in
639+ if firstChar == "/" then /. + url
640+ else if firstChar == "." then ./. + url
641+ else url;
642+ in if !fetchSubmodules && private then builtins.fetchGit {
643+ url = realUrl; inherit rev;
644+ ${if branch == null then null else "ref"} = branch;
645+ } else (import <nixpkgs> {}).fetchgit {
646+ url = realUrl; inherit rev sha256;
647+ };
648+ json = builtins.fromJSON (builtins.readFile ./git.json);
649+in if builtins.pathExists ./local then ./local else fetch json
650+|]
651+
652+parseGitJsonBytes :: LBS.ByteString -> Either String ThunkPtr
653+parseGitJsonBytes = parseJsonObject $ parseThunkPtr $ fmap ThunkSource_Git . parseGitSource
654+
655+mkThunkSpec :: Text -> FilePath -> (LBS.ByteString -> Either String ThunkPtr) -> Text -> ThunkSpec
656+mkThunkSpec name jsonFileName parser srcNix = ThunkSpec name $ Map.fromList
657+ [ ("default.nix", ThunkFileSpec_FileMatches defaultNixViaSrc)
658+ , ("thunk.nix", ThunkFileSpec_FileMatches srcNix)
659+ , (jsonFileName, ThunkFileSpec_Ptr parser)
660+ , (attrCacheFileName, ThunkFileSpec_AttrCache)
661+ , (unpackedDirName, ThunkFileSpec_CheckoutIndicator)
662+ ]
663+ where
664+ defaultNixViaSrc = [here|
665+# DO NOT HAND-EDIT THIS FILE
666+import (import ./thunk.nix)
667+|]
668+
669+
670+parseJsonObject :: (Aeson.Object -> Aeson.Parser a) -> LBS.ByteString -> Either String a
671+parseJsonObject p bytes = Aeson.parseEither p =<< Aeson.eitherDecode bytes
579672
580673-- | Checks a cache directory to see if there is a fresh symlink
581674-- to the result of building an attribute of a thunk.
@@ -583,44 +676,49 @@ thunkFileNames = ["default.nix", "github.json", "git.json"]
583676-- and the result is symlinked into the cache.
584677nixBuildThunkAttrWithCache
585678 :: MonadObelisk m
586− => FilePath
679+ => ThunkSpec
680+ -> FilePath
587681 -- ^ Path to directory containing Thunk
588682 -> String
589683 -- ^ Attribute to build
590− -> m FilePath
684+ -> m (Maybe FilePath)
591685 -- ^ Symlink to cached or built nix output
592686-- WARNING: If the thunk uses an impure reference such as '<nixpkgs>'
593687-- the caching mechanism will fail as it merely measures the modification
594688-- time of the cache link and the expression to build.
595−nixBuildThunkAttrWithCache thunkDir attr = do
596− --NB: Expects thunkDir to be normalised with no trailing path separator.
597− --This should be guaranteed by the command argument parser.
598− let cacheErrHandler e
599− | isDoesNotExistError e = return Nothing -- expected from a cache miss
600− | otherwise = putLog Error (T.pack $ displayException e) >> return Nothing
601− cacheDir = thunkDir </> attrCacheFileName
602− cachePath = cacheDir </> attr <.> "out"
689+nixBuildThunkAttrWithCache thunkSpec thunkDir attr = do
603690 latestChange <- liftIO $ do
604− createDirectoryIfMissing False cacheDir
605− let getModificationTimeMaybe = fmap rightToMaybe . try @IOError . getModificationTime
606− maximum . catMaybes <$> mapM (getModificationTimeMaybe . (thunkDir </>)) thunkFileNames
607− cacheHit <- handle cacheErrHandler $ do
608− cacheTime <- liftIO $ posixSecondsToUTCTime . realToFrac . modificationTime <$> getSymbolicLinkStatus cachePath
609− return $ if latestChange <= cacheTime
610− then Just cachePath
611− else Nothing
612− case cacheHit of
613− Just c -> return c
614− Nothing -> do
615− putLog Warning $ T.pack $ mconcat [thunkDir, ": ", attr, " not cached, building ..."]
616− _ <- nixCmd $ NixCmd_Build $ def
617− Lens.& nixBuildConfig_outLink Lens..~ OutLink_IndirectRoot cachePath
618− Lens.& nixCmdConfig_target Lens..~ Target
619− { _target_path = Just thunkDir
620− , _target_attr = Just attr
621− , _target_expr = Nothing
622− }
623− return cachePath
691+ let
692+ getModificationTimeMaybe = fmap rightToMaybe . try @IOError . getModificationTime
693+ thunkFileNames = Map.keys $ _thunkSpec_files thunkSpec
694+ maximum . catMaybes <$> traverse (getModificationTimeMaybe . (thunkDir </>)) thunkFileNames
695+
696+ let cachePaths' = nonEmpty $ Map.keys $ Map.filter (\case ThunkFileSpec_AttrCache -> True; _ -> False) $
697+ _thunkSpec_files thunkSpec
698+ for cachePaths' $ \cachePaths ->
699+ fmap NonEmpty.head $ for cachePaths $ \cacheDir -> do
700+ let
701+ cachePath = cacheDir </> attr <.> "out"
702+ cacheErrHandler e
703+ | isDoesNotExistError e = pure Nothing -- expected from a cache miss
704+ | otherwise = Nothing <$ putLog Error (T.pack $ displayException e)
705+ cacheHit <- handle cacheErrHandler $ do
706+ cacheTime <- liftIO $ posixSecondsToUTCTime . realToFrac . modificationTime <$> getSymbolicLinkStatus cachePath
707+ pure $ if latestChange <= cacheTime
708+ then Just cachePath
709+ else Nothing
710+ case cacheHit of
711+ Just c -> pure c
712+ Nothing -> do
713+ putLog Warning $ T.pack $ mconcat [thunkDir, ": ", attr, " not cached, building ..."]
714+ liftIO $ createDirectoryIfMissing True (takeDirectory cachePath)
715+ (cachePath <$) $ nixCmd $ NixCmd_Build $ def
716+ & nixBuildConfig_outLink .~ OutLink_IndirectRoot cachePath
717+ & nixCmdConfig_target .~ Target
718+ { _target_path = Just thunkDir
719+ , _target_attr = Just attr
720+ , _target_expr = Nothing
721+ }
624722
625723-- | Build a nix attribute, and cache the result if possible
626724nixBuildAttrWithCache
@@ -631,13 +729,15 @@ nixBuildAttrWithCache
631729 -- ^ Attribute to build
632730 -> m FilePath
633731 -- ^ Symlink to cached or built nix output
634−nixBuildAttrWithCache exprPath attr = do
635− readThunk exprPath >>= \case
636− -- Only packed thunks are cached. in particular, checkouts are not
637− Right (ThunkData_Packed _) -> nixBuildThunkAttrWithCache exprPath attr
638− _ -> nixCmd $ NixCmd_Build $ def
639− Lens.& nixBuildConfig_outLink Lens..~ OutLink_None
640− Lens.& nixCmdConfig_target Lens..~ Target
732+nixBuildAttrWithCache exprPath attr = readThunk exprPath >>= \case
733+ -- Only packed thunks are cached. In particular, checkouts are not.
734+ Right (ThunkData_Packed spec _) ->
735+ maybe build pure =<< nixBuildThunkAttrWithCache spec exprPath attr
736+ _ -> build
737+ where
738+ build = nixCmd $ NixCmd_Build $ def
739+ & nixBuildConfig_outLink .~ OutLink_None
740+ & nixCmdConfig_target .~ Target
641741 { _target_path = Just exprPath
642742 , _target_attr = Just attr
643743 , _target_expr = Nothing
@@ -658,7 +758,7 @@ updateThunk p f = withSystemTempDirectory "obelisk-thunkptr-" $ \tmpDir -> do
658758 where
659759 copyThunkToTmp tmpDir thunkDir = readThunk thunkDir >>= \case
660760 Left err -> failWith $ "withThunkUnpacked: " <> T.pack (show err)
661− Right (ThunkData_Packed _) -> do
761+ Right ThunkData_Packed{} -> do
662762 let tmpThunk = tmpDir </> "thunk"
663763 callProcessAndLogOutput (Notice, Error) $
664764 proc cp ["-r", "-T", thunkDir, tmpThunk]
@@ -676,58 +776,64 @@ unpackThunk :: MonadObelisk m => FilePath -> m ()
676776unpackThunk = unpackThunk' False
677777
678778-- | Check that we are not somewhere inside the thunk directory
679−checkThunkDirectory :: MonadObelisk m => Text -> FilePath -> m ()
680−checkThunkDirectory msg thunkDir = do
779+checkThunkDirectory :: MonadObelisk m => FilePath -> m ()
780+checkThunkDirectory thunkDir = do
681781 currentDir <- liftIO getCurrentDirectory
682782 thunkDir' <- liftIO $ canonicalizePath thunkDir
683− when (thunkDir' `L.isInfixOf` currentDir) $ failWith msg
783+ when (thunkDir' `L.isInfixOf` currentDir) $
784+ failWith [i|Can't perform thunk operations from within the thunk directory: ${thunkDir}|]
785+
786+ -- Don't let thunk commands work when directly given an unpacked repo
787+ when (takeFileName thunkDir == unpackedDirName) $
788+ readThunk (takeDirectory thunkDir) >>= \case
789+ Right _ -> failWith [i|Refusing to perform thunk operation on ${thunkDir} because it is a thunk's unpacked source|]
790+ Left _ -> pure ()
684791
685792unpackThunk' :: MonadObelisk m => Bool -> FilePath -> m ()
686−unpackThunk' noTrail thunkDir = checkThunkDirectory "Can't pack/unpack from within the thunk directory" thunkDir >> readThunk thunkDir >>= \case
687− Left err -> failWith $ "thunk unpack: " <> T.pack (show err)
793+unpackThunk' noTrail thunkDir = checkThunkDirectory thunkDir *> readThunk thunkDir >>= \case
794+ Left err -> failWith [i|Invalid thunk at ${thunkDir}: ${err}|]
688795 --TODO: Overwrite option that rechecks out thunk; force option to do so even if working directory is dirty
689− Right (ThunkData_Checkout _) -> failWith "thunk unpack: thunk is already unpacked"
690− Right (ThunkData_Packed tptr) -> do
796+ Right ThunkData_Checkout -> failWith [i|Thunk at ${thunkDir} is already unpacked|]
797+ Right (ThunkData_Packed _ tptr) -> do
691798 let (thunkParent, thunkName) = splitFileName thunkDir
692− withTempDirectory thunkParent thunkName $ \tmpRepo -> do
693− let obGitDir = tmpRepo </> ".git" </> "obelisk"
694− s = case _thunkPtr_source tptr of
695− ThunkSource_GitHub s' -> forgetGithub False s'
696− ThunkSource_Git s' -> s'
799+ withTempDirectory thunkParent thunkName $ \tmpThunk -> do
800+ let
801+ (gitSrc, newSpec) = case _thunkPtr_source tptr of
802+ ThunkSource_GitHub s' -> (forgetGithub False s', NonEmpty.head gitHubThunkSpecs)
803+ ThunkSource_Git s' -> (s', NonEmpty.head gitThunkSpecs)
697804 withSpinner' ("Fetching thunk " <> T.pack thunkName)
698805 (finalMsg noTrail $ const $ "Fetched thunk " <> T.pack thunkName) $ do
699− let git = callProcessAndLogOutput (Notice, Notice) . gitProc tmpRepo
806+ let git = callProcessAndLogOutput (Notice, Notice) . gitProc (tmpThunk </> unpackedDirName)
700807 git $ [ "clone" ]
701− ++ ("--recursive" <$ guard (_gitSource_fetchSubmodules s))
702− ++ [ T.unpack $ gitUriToText $ _gitSource_url s ]
703− ++ do branch <- maybeToList $ _gitSource_branch s
808+ ++ ["--recursive" | _gitSource_fetchSubmodules gitSrc]
809+ ++ [ T.unpack $ gitUriToText $ _gitSource_url gitSrc ]
810+ ++ do branch <- maybeToList $ _gitSource_branch gitSrc
704811 [ "--branch", T.unpack $ untagName branch ]
705812 git ["reset", "--hard", Ref.toHexString $ _thunkRev_commit $ _thunkPtr_rev tptr]
706− when (_gitSource_fetchSubmodules s) $
813+ when (_gitSource_fetchSubmodules gitSrc) $
707814 git ["submodule", "update", "--recursive", "--init"]
708815
709− liftIO $ createDirectory obGitDir
710− callProcessAndLogOutput (Notice, Error) $
711− proc cp ["-r", "-T", thunkDir </> ".", obGitDir </> "orig-thunk"]
712− callProcessAndLogOutput (Notice, Error) $
713− proc "rm" ["-r", thunkDir]
714− callProcessAndLogOutput (Notice, Error) $
715− proc "mv" ["-T", tmpRepo, thunkDir]
816+ createThunk tmpThunk $ Left newSpec
817+
818+ liftIO $ do
819+ removePathForcibly thunkDir
820+ renameDirectory tmpThunk thunkDir
821+
716822
717823--TODO: add a rollback mode to pack to the original thunk
718824packThunk :: MonadObelisk m => ThunkPackConfig -> FilePath -> m ThunkPtr
719825packThunk = packThunk' False
720826
721827packThunk' :: MonadObelisk m => Bool -> ThunkPackConfig -> FilePath -> m ThunkPtr
722−packThunk' noTrail (ThunkPackConfig force thunkConfig) thunkDir = checkThunkDirectory "Can't pack/unpack from within the thunk directory" thunkDir >> readThunk thunkDir >>= \case
723− Left err -> failWith $ T.pack $ "thunk pack: " <> show err
724− Right (ThunkData_Packed _) -> failWith "pack: thunk is already packed"
725− Right (ThunkData_Checkout _) -> do
726− withSpinner' ("Packing thunk " <> T.pack thunkDir)
727− (finalMsg noTrail $ const $ "Packed thunk " <> T.pack thunkDir) $ do
828+packThunk' noTrail (ThunkPackConfig force thunkConfig) thunkDir = checkThunkDirectory thunkDir *> readThunk thunkDir >>= \case
829+ Right ThunkData_Packed{} -> failWith [i|Thunk at ${thunkDir} is is already packed|]
830+ _ -> withSpinner'
831+ ("Packing thunk " <> T.pack thunkDir)
832+ (finalMsg noTrail $ const $ "Packed thunk " <> T.pack thunkDir) $
833+ do
728834 thunkPtr <- modifyThunkPtrByConfig thunkConfig <$> getThunkPtr (not force) thunkDir (_thunkConfig_private thunkConfig)
729− callProcessAndLogOutput (Debug, Error) $ proc "rm" ["-rf", thunkDir]
730− liftIO $ createThunk thunkDir thunkPtr
835+ callProcessAndLogOutput (Debug, Error) $ proc rmPath ["-rf", thunkDir] -- thunkDir may be a symlink
836+ createThunk thunkDir $ Right thunkPtr
731837 pure thunkPtr
732838
733839modifyThunkPtrByConfig :: ThunkConfig -> ThunkPtr -> ThunkPtr
@@ -739,28 +845,29 @@ modifyThunkPtrByConfig (ThunkConfig markPrivate') ptr = case markPrivate' of
739845 }
740846
741847getThunkPtr :: forall m. MonadObelisk m => Bool -> FilePath -> Maybe Bool -> m ThunkPtr
742−getThunkPtr checkClean thunkDir mPrivate = do
848+getThunkPtr checkClean dir mPrivate = do
849+ let repoLocations = [(".git", "."), (unpackedDirName, unpackedDirName)]
850+ repoLocation' <- liftIO $ flip findM repoLocations $ doesDirectoryExist . (dir </>) . fst
851+ thunkDir <- case repoLocation' of
852+ Nothing -> failWith [i|Can't find an unpacked thunk in ${dir}|]
853+ Just (_, path) -> pure $ normalise $ dir </> path
854+
743855 when checkClean $ ensureCleanGitRepo thunkDir True
744856 "thunk pack: thunk checkout contains unsaved modifications"
745857
746858 -- Check whether there are any stashes
747− stashOutput <- readGitProcess thunkDir ["stash", "list"]
748− when checkClean $ case T.null stashOutput of
749− False -> do
859+ when checkClean $ do
860+ stashOutput <- readGitProcess thunkDir ["stash", "list"]
861+ unless (T.null stashOutput) $
750862 failWith $ T.unlines $
751863 [ "thunk pack: thunk checkout has stashes"
752864 , "git stash list:"
753865 ] ++ T.lines stashOutput
754− True -> return ()
755866
756867 -- Get current branch
757868 (mCurrentBranch, mCurrentCommit) <- do
758− b <- listToMaybe
759− <$> T.lines
760− <$> readGitProcess thunkDir ["rev-parse", "--abbrev-ref", "HEAD"]
761− c <- listToMaybe
762− <$> T.lines
763− <$> readGitProcess thunkDir ["rev-parse", "HEAD"]
869+ b <- listToMaybe . T.lines <$> readGitProcess thunkDir ["rev-parse", "--abbrev-ref", "HEAD"]
870+ c <- listToMaybe . T.lines <$> readGitProcess thunkDir ["rev-parse", "HEAD"]
764871 case b of
765872 (Just "HEAD") -> failWith $ T.unlines
766873 [ "thunk pack: You are in 'detached HEAD' state."
@@ -771,7 +878,7 @@ getThunkPtr checkClean thunkDir mPrivate = do
771878
772879 -- Get information on all branches and their (optional) designated upstream
773880 -- correspondents
774− (headDump :: [Text]) <- T.lines <$> readGitProcess thunkDir
881+ headDump :: [Text] <- T.lines <$> readGitProcess thunkDir
775882 [ "for-each-ref"
776883 , "--format=%(refname:short) %(upstream:short) %(upstream:remotename)"
777884 , "refs/heads/"
@@ -817,7 +924,7 @@ getThunkPtr checkClean thunkDir mPrivate = do
817924 ]
818925
819926 -- loosely by https://stackoverflow.com/questions/7773939/show-git-ahead-and-behind-info-for-all-branches-including-remotes
820− stats <- iforM headUpstream $ \branch (upstream, _remote) -> do
927+ stats <- ifor headUpstream $ \branch (upstream, _remote) -> do
821928 (stat :: [Text]) <- T.lines <$> readGitProcess thunkDir
822929 [ "rev-list", "--left-right"
823930 , T.unpack branch <> "..." <> T.unpack upstream
@@ -841,8 +948,9 @@ getThunkPtr checkClean thunkDir mPrivate = do
841948 \pushed but this repo's remote tracking branches don't know it.)"
842949 ]
843950
844− -- We assume it's safe to pack the thunk at this point
845− putLog Informational "All changes safe in git remotes. OK to pack thunk."
951+ when checkClean $ do
952+ -- We assume it's safe to pack the thunk at this point
953+ putLog Informational "All changes safe in git remotes. OK to pack thunk."
846954
847955 let remote = maybe "origin" snd $ flip Map.lookup headUpstream =<< mCurrentBranch
848956