f781e57 · obelisk · git.iko.soy

git.iko.soy/obelisk

on master help sign in

command: Add ob thunk init and better error checks

f781e57Elliot Cameron7 years ago

lib/command/src/Obelisk/Command.hs+3

compare with master

unifiedsplit

@@ -228,6 +228,7 @@ data ThunkCommand

228 = ThunkCommand_Update [FilePath] ThunkUpdateConfig

229 | ThunkCommand_Unpack [FilePath]

230 | ThunkCommand_Pack [FilePath] ThunkPackConfig

231+ | ThunkCommand_Init [FilePath]

231 deriving Show

232 deriving Show

232

233

233thunkCommand :: Parser ThunkCommand

234thunkCommand :: Parser ThunkCommand

@@ -235,6 +236,7 @@ thunkCommand = hsubparser $ mconcat

235 [ command "update" $ info (ThunkCommand_Update <$> some thunkDirectoryParser <*> thunkUpdateConfig) $ progDesc "Update thunk to latest revision available"

236 [ command "update" $ info (ThunkCommand_Update <$> some thunkDirectoryParser <*> thunkUpdateConfig) $ progDesc "Update thunk to latest revision available"

236 , command "unpack" $ info (ThunkCommand_Unpack <$> some thunkDirectoryParser) $ progDesc "Unpack thunk into git checkout of revision it points to"

237 , command "unpack" $ info (ThunkCommand_Unpack <$> some thunkDirectoryParser) $ progDesc "Unpack thunk into git checkout of revision it points to"

237 , command "pack" $ info (ThunkCommand_Pack <$> some thunkDirectoryParser <*> thunkPackConfig) $ progDesc "Pack git checkout into thunk that points at the current branch's upstream"

238 , command "pack" $ info (ThunkCommand_Pack <$> some thunkDirectoryParser <*> thunkPackConfig) $ progDesc "Pack git checkout into thunk that points at the current branch's upstream"

239+ , command "init" $ info (ThunkCommand_Init <$> some thunkDirectoryParser) $ progDesc "Initialize a git checkout by converting it to an unpacked thunk"

238 ]

240 ]

239

241

240data ShellOpts

242data ShellOpts

@@ -378,6 +380,7 @@ ob = \case

378 ThunkCommand_Update thunks config -> for_ thunks (updateThunkToLatest config)

380 ThunkCommand_Update thunks config -> for_ thunks (updateThunkToLatest config)

379 ThunkCommand_Unpack thunks -> for_ thunks unpackThunk

381 ThunkCommand_Unpack thunks -> for_ thunks unpackThunk

380 ThunkCommand_Pack thunks config -> for_ thunks (packThunk config)

382 ThunkCommand_Pack thunks config -> for_ thunks (packThunk config)

383+ ThunkCommand_Init thunks -> for_ thunks initThunk

381 ObCommand_Repl -> runRepl

384 ObCommand_Repl -> runRepl

382 ObCommand_Watch -> runWatch

385 ObCommand_Watch -> runWatch

383 ObCommand_Shell so -> withProjectRoot "." $ \root ->

386 ObCommand_Shell so -> withProjectRoot "." $ \root ->

lib/command/src/Obelisk/Command/Thunk.hs+83−78

@@ -14,7 +14,7 @@ import Control.Applicative

14import Control.Exception (displayException, try)

15import Control.Lens (ifor, ifor_, (.~))

16import Control.Monad

17−import Control.Monad.Extra (findM)

17+import Control.Monad.Extra (findM, unlessM, whenM)

18import Control.Monad.Catch (MonadCatch, handle)

19import Control.Monad.Except

20import Data.Aeson ((.=))

@@ -27,6 +27,7 @@ import Data.Default

27import Data.Either.Combinators (fromRight', rightToMaybe)

28import Data.Foldable (toList)

29import Data.Function ((&))

30+import Data.Functor ((<&>))

30import Data.Git.Ref (Ref)

31import Data.Git.Ref (Ref)

31import qualified Data.Git.Ref as Ref

32import qualified Data.Git.Ref as Ref

32import qualified Data.List as L

33import qualified Data.List as L

@@ -193,46 +194,12 @@ nixPrefetchGit uri rev fetchSubmodules =

193data ReadThunkError

194data ReadThunkError

194 = ReadThunkError_UnrecognizedPaths (NonEmpty FilePath)

195 = ReadThunkError_UnrecognizedPaths (NonEmpty FilePath)

195 | ReadThunkError_MissingPaths (NonEmpty FilePath)

196 | ReadThunkError_MissingPaths (NonEmpty FilePath)

196− | ReadThunkError_UnrecognizedThunk -- TODO: Delete?

197+ | ReadThunkError_UnrecognizedThunk

197 | ReadThunkError_UnparseablePtr FilePath String

198 | ReadThunkError_UnparseablePtr FilePath String

198 | ReadThunkError_FileError IOError

199 | ReadThunkError_FileError IOError

199 | ReadThunkError_FileDoesNotMatch FilePath Text

200 | ReadThunkError_FileDoesNotMatch FilePath Text

200 deriving (Show)

201 deriving (Show)

201

202

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−

236unpackedDirName :: FilePath

203unpackedDirName :: FilePath

237unpackedDirName = "_"

204unpackedDirName = "_"

238

205

@@ -241,11 +208,10 @@ attrCacheFileName = ".attr-cache"

241

208

242-- | Specification for how a file in a thunk version works.

209-- | Specification for how a file in a thunk version works.

243data ThunkFileSpec

210data ThunkFileSpec

244− = ThunkFileSpec_FileMayExist

245− | ThunkFileSpec_DirMayExist

246− | ThunkFileSpec_AttrCache

247− | ThunkFileSpec_Ptr (LBS.ByteString -> Either String ThunkPtr)

211+ = ThunkFileSpec_Ptr (LBS.ByteString -> Either String ThunkPtr) -- ^ This file specifies a parser for 'ThunkPtr' data

248− | ThunkFileSpec_FileMatches Text

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

249

215

250-- | Specification for how a set of files in a thunk version work.

216-- | Specification for how a set of files in a thunk version work.

251data ThunkSpec = ThunkSpec

217data ThunkSpec = ThunkSpec

@@ -262,7 +228,7 @@ matchThunkSpecToDir

262 => ThunkSpec -- ^ 'ThunkSpec' to match against the given files/directory

228 => ThunkSpec -- ^ 'ThunkSpec' to match against the given files/directory

263 -> FilePath -- ^ Path to directory

229 -> FilePath -- ^ Path to directory

264 -> Set FilePath -- ^ Set of file paths relative to the given directory

230 -> Set FilePath -- ^ Set of file paths relative to the given directory

265− -> m ThunkPtr

231+ -> m ThunkData

266matchThunkSpecToDir thunkSpec dir dirFiles = do

232matchThunkSpecToDir thunkSpec dir dirFiles = do

267 case nonEmpty (toList $ dirFiles `Set.difference` expectedPaths) of

233 case nonEmpty (toList $ dirFiles `Set.difference` expectedPaths) of

268 Just fs -> throwError $ ReadThunkError_UnrecognizedPaths $ (dir </>) <$> fs

234 Just fs -> throwError $ ReadThunkError_UnrecognizedPaths $ (dir </>) <$> fs

@@ -270,12 +236,11 @@ matchThunkSpecToDir thunkSpec dir dirFiles = do

270 case nonEmpty (toList $ requiredPaths `Set.difference` dirFiles) of

236 case nonEmpty (toList $ requiredPaths `Set.difference` dirFiles) of

271 Just fs -> throwError $ ReadThunkError_MissingPaths $ (dir </>) <$> fs

237 Just fs -> throwError $ ReadThunkError_MissingPaths $ (dir </>) <$> fs

272 Nothing -> pure ()

238 Nothing -> pure ()

273− ptrs <- fmap toList $ flip Map.traverseMaybeWithKey (_thunkSpec_files thunkSpec) $ \expectedPath -> \case

239+ datas <- fmap toList $ flip Map.traverseMaybeWithKey (_thunkSpec_files thunkSpec) $ \expectedPath -> \case

240+ ThunkFileSpec_AttrCache -> Nothing <$ dirMayExist expectedPath

274− ThunkFileSpec_FileMayExist -> liftIO (doesDirectoryExist (dir </> expectedPath)) >>= \case

241+ ThunkFileSpec_CheckoutIndicator -> liftIO (doesDirectoryExist (dir </> expectedPath)) <&> \case

275− True -> throwError $ ReadThunkError_UnrecognizedPaths $ expectedPath :| []

242+ False -> Nothing

276− False -> pure Nothing

243+ True -> Just (ThunkData_Checkout Nothing)

277− ThunkFileSpec_DirMayExist -> dirMayExist expectedPath

278− ThunkFileSpec_AttrCache -> dirMayExist expectedPath

279 ThunkFileSpec_FileMatches expectedContents -> handle (\(e :: IOError) -> throwError $ ReadThunkError_FileError e) $ do

244 ThunkFileSpec_FileMatches expectedContents -> handle (\(e :: IOError) -> throwError $ ReadThunkError_FileError e) $ do

280 actualContents <- liftIO (T.readFile $ dir </> expectedPath)

245 actualContents <- liftIO (T.readFile $ dir </> expectedPath)

281 case T.strip expectedContents == T.strip actualContents of

246 case T.strip expectedContents == T.strip actualContents of

@@ -284,16 +249,19 @@ matchThunkSpecToDir thunkSpec dir dirFiles = do

284 ThunkFileSpec_Ptr parser -> handle (\(e :: IOError) -> throwError $ ReadThunkError_FileError e) $ do

249 ThunkFileSpec_Ptr parser -> handle (\(e :: IOError) -> throwError $ ReadThunkError_FileError e) $ do

285 actualContents <- liftIO $ LBS.readFile $ dir </> expectedPath

250 actualContents <- liftIO $ LBS.readFile $ dir </> expectedPath

286 case parser actualContents of

251 case parser actualContents of

287− Right v -> pure $ Just v

252+ Right v -> pure $ Just (ThunkData_Packed (thunkSpec, v))

288 Left e -> throwError $ ReadThunkError_UnparseablePtr (dir </> expectedPath) e

253 Left e -> throwError $ ReadThunkError_UnparseablePtr (dir </> expectedPath) e

289

254

290− case nubOrd ptrs of

255+ case nonEmpty datas of

291− [x] -> pure x

256+ Nothing -> throwError ReadThunkError_UnrecognizedThunk

292− _ -> throwError ReadThunkError_UnrecognizedThunk

257+ Just xs -> fold1WithM xs $ \a b -> maybe (throwError ReadThunkError_UnrecognizedThunk) pure (mergeThunkData a b)

293−

294 where

258 where

259+ rootPathsOnly = Set.fromList . mapMaybe takeRootDir . Map.keys

260+ takeRootDir = fmap NonEmpty.head . nonEmpty . splitPath

261+

295− expectedPaths = Map.keysSet $ _thunkSpec_files thunkSpec

262+ expectedPaths = rootPathsOnly $ _thunkSpec_files thunkSpec

263+

296− requiredPaths = Map.keysSet $ Map.filter isRequiredFileSpec $ _thunkSpec_files thunkSpec

264+ requiredPaths = rootPathsOnly $ Map.filter isRequiredFileSpec $ _thunkSpec_files thunkSpec

297 isRequiredFileSpec = \case

265 isRequiredFileSpec = \case

298 ThunkFileSpec_FileMatches _ -> True

266 ThunkFileSpec_FileMatches _ -> True

299 ThunkFileSpec_Ptr _ -> True

267 ThunkFileSpec_Ptr _ -> True

@@ -301,26 +269,36 @@ matchThunkSpecToDir thunkSpec dir dirFiles = do

301

269

302 dirMayExist expectedPath = liftIO (doesFileExist (dir </> expectedPath)) >>= \case

270 dirMayExist expectedPath = liftIO (doesFileExist (dir </> expectedPath)) >>= \case

303 True -> throwError $ ReadThunkError_UnrecognizedPaths $ expectedPath :| []

271 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

305

283

306−readPackedThunkWith

284+ fold1WithM (x :| xs) f = foldM f x xs

285+

286+readThunkWith

307 :: (MonadObelisk m)

287 :: (MonadObelisk m)

308− => NonEmpty (NonEmpty ThunkSpec) -> FilePath -> m (Either ReadThunkError (ThunkSpec, ThunkPtr))

288+ => NonEmpty (NonEmpty ThunkSpec) -> FilePath -> m (Either ReadThunkError ThunkData)

309−readPackedThunkWith specTypes dir = do

289+readThunkWith specTypes dir = do

310 dirFiles <- Set.fromList <$> liftIO (listDirectory dir)

290 dirFiles <- Set.fromList <$> liftIO (listDirectory dir)

311 let specs = concatMap toList $ toList $ NonEmpty.transpose specTypes -- Interleave spec types so we try each one in a "fair" ordering

291 let specs = concatMap toList $ toList $ NonEmpty.transpose specTypes -- Interleave spec types so we try each one in a "fair" ordering

312 flip fix specs $ \loop -> \case

292 flip fix specs $ \loop -> \case

313 [] -> pure $ Left ReadThunkError_UnrecognizedThunk

293 [] -> pure $ Left ReadThunkError_UnrecognizedThunk

314 spec:rest -> runExceptT (matchThunkSpecToDir spec dir dirFiles) >>= \case

294 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}|]

295+ Left e -> loop rest <* putLog Debug [i|Thunk specification ${_thunkSpec_name spec} did not match ${dir}: ${e}|]

317− loop rest

318− Right ptr -> Right (spec, ptr) <$ putLog Debug ("Thunk " <> _thunkSpec_name spec <> " matched " <> T.pack dir)

296+ x@(Right _) -> x <$ putLog Debug [i|Thunk specification ${_thunkSpec_name spec} matched ${dir}|]

319

297

320-- | Read a thunk and validate that it is exactly a packed thunk.

298-- | Read a thunk and validate that it is exactly a packed thunk.

321-- If additional data is present, fail.

299-- If additional data is present, fail.

322−readPackedThunk :: (MonadObelisk m) => FilePath -> m (Either ReadThunkError (ThunkSpec, ThunkPtr))

300+readThunk :: (MonadObelisk m) => FilePath -> m (Either ReadThunkError ThunkData)

323−readPackedThunk = readPackedThunkWith thunkSpecTypes

301+readThunk = readThunkWith thunkSpecTypes

324

302

325parseThunkPtr :: (Aeson.Object -> Aeson.Parser ThunkSource) -> Aeson.Object -> Aeson.Parser ThunkPtr

303parseThunkPtr :: (Aeson.Object -> Aeson.Parser ThunkSource) -> Aeson.Object -> Aeson.Parser ThunkPtr

326parseThunkPtr parseSrc v = do

304parseThunkPtr parseSrc v = do

@@ -422,6 +400,21 @@ encodeThunkPtrData (ThunkPtr rev src) = case src of

422 , confTrailingNewline = True

400 , confTrailingNewline = True

423 }

401 }

424

402

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+

425createThunk :: MonadObelisk m => FilePath -> ThunkPtr -> m ()

418createThunk :: MonadObelisk m => FilePath -> ThunkPtr -> m ()

426createThunk target ptr =

419createThunk target ptr =

427 ifor_ (_thunkSpec_files $ thunkPtrToSpec ptr) $ \path -> \case

420 ifor_ (_thunkSpec_files $ thunkPtrToSpec ptr) $ \path -> \case

@@ -444,8 +437,8 @@ createThunkWithLatest target s = do

444 }

437 }

445

438

446updateThunkToLatest :: MonadObelisk m => ThunkUpdateConfig -> FilePath -> m ()

439updateThunkToLatest :: 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

440+updateThunkToLatest (ThunkUpdateConfig mBranch thunkConfig) target = spinner $ do

448− checkThunkDirectory "ob thunk update directory cannot be '.'" target

441+ checkThunkDirectory target

449 -- check to see if thunk should be updated to a specific branch or just update it's current branch

442 -- check to see if thunk should be updated to a specific branch or just update it's current branch

450 case mBranch of

443 case mBranch of

451 Nothing -> do

444 Nothing -> do

@@ -469,6 +462,8 @@ updateThunkToLatest (ThunkUpdateConfig mBranch thunkConfig) target = withSpinner

469 let tsg = forgetGithub False tsgh

462 let tsg = forgetGithub False tsgh

470 setThunk thunkConfig target tsg branch

463 setThunk thunkConfig target tsg branch

471 ThunkData_Checkout _ -> failWith $ T.pack $ "thunk located at " <> show target <> " is unpacked. Use ob thunk pack on the desired directory and then try ob thunk update again."

464 ThunkData_Checkout _ -> failWith $ T.pack $ "thunk located at " <> show target <> " is unpacked. Use ob thunk pack on the desired directory and then try ob thunk update again."

465+ where

466+ spinner = withSpinner' ("Updating thunk " <> T.pack target <> " to latest") (pure $ const $ "Thunk " <> T.pack target <> " updated to latest")

472

467

473setThunk :: MonadObelisk m => ThunkConfig -> FilePath -> GitSource -> String -> m ()

468setThunk :: MonadObelisk m => ThunkConfig -> FilePath -> GitSource -> String -> m ()

474setThunk thunkConfig target gs branch = do

469setThunk thunkConfig target gs branch = do

@@ -539,6 +534,7 @@ legacyGitHubThunkSpec name loader = ThunkSpec name $ Map.fromList

539 [ ("default.nix", ThunkFileSpec_FileMatches $ T.strip loader)

534 [ ("default.nix", ThunkFileSpec_FileMatches $ T.strip loader)

540 , ("github.json" , ThunkFileSpec_Ptr parseGitHubJsonBytes)

535 , ("github.json" , ThunkFileSpec_Ptr parseGitHubJsonBytes)

541 , (attrCacheFileName, ThunkFileSpec_AttrCache)

536 , (attrCacheFileName, ThunkFileSpec_AttrCache)

537+ , (".git", ThunkFileSpec_CheckoutIndicator)

542 ]

538 ]

543

539

544gitHubThunkSpecV5 :: ThunkSpec

540gitHubThunkSpecV5 :: ThunkSpec

@@ -624,6 +620,7 @@ legacyGitThunkSpec name loader = ThunkSpec name $ Map.fromList

624 [ ("default.nix", ThunkFileSpec_FileMatches $ T.strip loader)

620 [ ("default.nix", ThunkFileSpec_FileMatches $ T.strip loader)

625 , ("git.json" , ThunkFileSpec_Ptr parseGitJsonBytes)

621 , ("git.json" , ThunkFileSpec_Ptr parseGitJsonBytes)

626 , (attrCacheFileName, ThunkFileSpec_AttrCache)

622 , (attrCacheFileName, ThunkFileSpec_AttrCache)

623+ , (".git", ThunkFileSpec_CheckoutIndicator)

627 ]

624 ]

628

625

629gitThunkSpecV5 :: ThunkSpec

626gitThunkSpecV5 :: ThunkSpec

@@ -652,6 +649,7 @@ mkThunkSpec name jsonFileName parser srcNix = ThunkSpec name $ Map.fromList

652 , ("src.nix", ThunkFileSpec_FileMatches srcNix)

649 , ("src.nix", ThunkFileSpec_FileMatches srcNix)

653 , (jsonFileName, ThunkFileSpec_Ptr parser)

650 , (jsonFileName, ThunkFileSpec_Ptr parser)

654 , (attrCacheFileName, ThunkFileSpec_AttrCache)

651 , (attrCacheFileName, ThunkFileSpec_AttrCache)

652+ , (unpackedDirName, ThunkFileSpec_CheckoutIndicator)

655 ]

653 ]

656 where

654 where

657 defaultNixViaSrc = [here|

655 defaultNixViaSrc = [here|

@@ -769,14 +767,21 @@ unpackThunk :: MonadObelisk m => FilePath -> m ()

769unpackThunk = unpackThunk' False

767unpackThunk = unpackThunk' False

770

768

771-- | Check that we are not somewhere inside the thunk directory

769-- | Check that we are not somewhere inside the thunk directory

772−checkThunkDirectory :: MonadObelisk m => Text -> FilePath -> m ()

770+checkThunkDirectory :: MonadObelisk m => FilePath -> m ()

773−checkThunkDirectory msg thunkDir = do

771+checkThunkDirectory thunkDir = do

774 currentDir <- liftIO getCurrentDirectory

772 currentDir <- liftIO getCurrentDirectory

775 thunkDir' <- liftIO $ canonicalizePath thunkDir

773 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 ()

777

782

778unpackThunk' :: MonadObelisk m => Bool -> FilePath -> m ()

783unpackThunk' :: 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

780 Left err -> failWith [i|Invalid thunk at ${thunkDir}: ${err}|]

785 Left err -> failWith [i|Invalid thunk at ${thunkDir}: ${err}|]

781 --TODO: Overwrite option that rechecks out thunk; force option to do so even if working directory is dirty

786 --TODO: Overwrite option that rechecks out thunk; force option to do so even if working directory is dirty

782 Right (ThunkData_Checkout _) -> failWith [i|Thunk at ${thunkDir} is already unpacked|]

787 Right (ThunkData_Checkout _) -> failWith [i|Thunk at ${thunkDir} is already unpacked|]

@@ -808,7 +813,7 @@ packThunk :: MonadObelisk m => ThunkPackConfig -> FilePath -> m ThunkPtr

808packThunk = packThunk' False

813packThunk = packThunk' False

809

814

810packThunk' :: MonadObelisk m => Bool -> ThunkPackConfig -> FilePath -> m ThunkPtr

815packThunk' :: 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

812 Left err -> failWith [i|Can't pack thunk at ${thunkDir}: ${err}|]

817 Left err -> failWith [i|Can't pack thunk at ${thunkDir}: ${err}|]

813 Right (ThunkData_Packed _) -> failWith [i|Thunk at ${thunkDir} is is already packed|]

818 Right (ThunkData_Packed _) -> failWith [i|Thunk at ${thunkDir} is is already packed|]

814 Right (ThunkData_Checkout _) -> do

819 Right (ThunkData_Checkout _) -> do

@@ -839,14 +844,13 @@ getThunkPtr checkClean dir mPrivate = do

839 "thunk pack: thunk checkout contains unsaved modifications"

844 "thunk pack: thunk checkout contains unsaved modifications"

840

845

841 -- Check whether there are any stashes

846 -- Check whether there are any stashes

847+ when checkClean $ do

842− stashOutput <- readGitProcess thunkDir ["stash", "list"]

848+ stashOutput <- readGitProcess thunkDir ["stash", "list"]

843− when checkClean $ case T.null stashOutput of

849+ unless (T.null stashOutput) $

844− False -> do

845 failWith $ T.unlines $

850 failWith $ T.unlines $

846 [ "thunk pack: thunk checkout has stashes"

851 [ "thunk pack: thunk checkout has stashes"

847 , "git stash list:"

852 , "git stash list:"

848 ] ++ T.lines stashOutput

853 ] ++ T.lines stashOutput

849− True -> return ()

850

854

851 -- Get current branch

855 -- Get current branch

852 (mCurrentBranch, mCurrentCommit) <- do

856 (mCurrentBranch, mCurrentCommit) <- do

@@ -932,8 +936,9 @@ getThunkPtr checkClean dir mPrivate = do

932 \pushed but this repo's remote tracking branches don't know it.)"

936 \pushed but this repo's remote tracking branches don't know it.)"

933 ]

937 ]

934

938

939+ when checkClean $ do

935− -- We assume it's safe to pack the thunk at this point

940+ -- 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."

941+ putLog Informational "All changes safe in git remotes. OK to pack thunk."

937

942

938 let remote = maybe "origin" snd $ flip Map.lookup headUpstream =<< mCurrentBranch

943 let remote = maybe "origin" snd $ flip Map.lookup headUpstream =<< mCurrentBranch

939

944