@@ -5,67 +5,48 @@
5{-# LANGUAGE MultiWayIf #-}
5{-# LANGUAGE MultiWayIf #-}
6{-# LANGUAGE OverloadedStrings #-}
6{-# LANGUAGE OverloadedStrings #-}
7{-# LANGUAGE PatternGuards #-}
7{-# LANGUAGE PatternGuards #-}
8+{-# LANGUAGE QuasiQuotes #-}
8{-# LANGUAGE ScopedTypeVariables #-}
9{-# LANGUAGE ScopedTypeVariables #-}
9{-# LANGUAGE TypeApplications #-}
10{-# LANGUAGE TypeApplications #-}
10−module Obelisk.Command.Thunk
11+module Obelisk.Command.Thunk where
13− , ReadThunkError (..)
16− , ThunkPackConfig (..)
20− , ThunkUpdateConfig (..)
23− , createThunkWithLatest
28− , nixBuildAttrWithCache
29− , nixBuildThunkAttrWithCache
35− , updateThunkToLatest
39import Control.Applicative
13import Control.Applicative
40import Control.Exception (displayException, try)
14import Control.Exception (displayException, try)
41−import qualified Control.Lens as Lens
15+import Control.Lens (ifor, ifor_, (.~))
42−import Control.Lens.Indexed hiding ((<.>))
43import Control.Monad
16import Control.Monad
44−import Control.Monad.Catch (handle)
17+import Control.Monad.Extra (findM)
18+import Control.Monad.Catch (MonadCatch, handle)
45import Control.Monad.Except
19import Control.Monad.Except
46import Data.Aeson ((.=))
20import Data.Aeson ((.=))
47import qualified Data.Aeson as Aeson
21import qualified Data.Aeson as Aeson
48import Data.Aeson.Encode.Pretty
22import Data.Aeson.Encode.Pretty
49import qualified Data.Aeson.Types as Aeson
23import qualified Data.Aeson.Types as Aeson
24+import Data.Bifunctor (first)
50import qualified Data.ByteString.Lazy as LBS
25import qualified Data.ByteString.Lazy as LBS
51import Data.Containers.ListUtils (nubOrd)
26import Data.Containers.ListUtils (nubOrd)
52import Data.Default
27import Data.Default
53import Data.Either.Combinators (fromRight', rightToMaybe)
28import Data.Either.Combinators (fromRight', rightToMaybe)
29+import Data.Foldable (toList)
30+import Data.Function ((&))
31+import Data.Functor ((<&>))
54import Data.Git.Ref (Ref)
32import Data.Git.Ref (Ref)
55import qualified Data.Git.Ref as Ref
33import qualified Data.Git.Ref as Ref
56import qualified Data.List as L
34import qualified Data.List as L
57−import Data.List.NonEmpty (NonEmpty (..))
35+import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
58import qualified Data.List.NonEmpty as NonEmpty
36import qualified Data.List.NonEmpty as NonEmpty
59import Data.Map (Map)
37import Data.Map (Map)
60import qualified Data.Map as Map
38import qualified Data.Map as Map
61import Data.Maybe
39import Data.Maybe
62import Data.Set (Set)
40import Data.Set (Set)
63import qualified Data.Set as Set
41import qualified Data.Set as Set
42+import Data.String.Here.Interpolated (i)
43+import Data.String.Here.Uninterpolated (here)
64import Data.Text (Text)
44import Data.Text (Text)
65import qualified Data.Text as T
45import qualified Data.Text as T
66import Data.Text.Encoding
46import Data.Text.Encoding
67import qualified Data.Text.IO as T
47import qualified Data.Text.IO as T
68import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
48import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
49+import Data.Traversable (for)
69import Data.Yaml (parseMaybe)
50import Data.Yaml (parseMaybe)
70import GitHub
51import GitHub
71import GitHub.Data.Name
52import GitHub.Data.Name
@@ -75,7 +56,7 @@ import System.Exit
75import System.FilePath
56import System.FilePath
76import System.IO.Error
57import System.IO.Error
77import System.IO.Temp
58import System.IO.Temp
78−import System.Posix (getSymbolicLinkStatus, modificationTime)
59+import System.PosixCompat.Files (getSymbolicLinkStatus, modificationTime)
79import qualified Text.URI as URI
60import qualified Text.URI as URI
81import Obelisk.App (MonadObelisk)
62import Obelisk.App (MonadObelisk)
@@ -84,11 +65,10 @@ import Obelisk.Command.Utils
85--TODO: Support symlinked thunk data
66--TODO: Support symlinked thunk data
86data ThunkData
67data ThunkData
87− = ThunkData_Packed ThunkPtr
68+ = ThunkData_Packed ThunkSpec ThunkPtr
88 -- ^ Packed thunk
69 -- ^ Packed thunk
89− | ThunkData_Checkout (Maybe ThunkPtr)
70+ | ThunkData_Checkout
90 -- ^ Checked out thunk that was unpacked from this pointer
71 -- ^ Checked out thunk that was unpacked from this pointer
91− deriving (Show, Eq, Ord)
93-- | A reference to the exact data that a thunk should translate into
73-- | A reference to the exact data that a thunk should translate into
94data ThunkPtr = ThunkPtr
74data ThunkPtr = ThunkPtr
@@ -114,6 +94,11 @@ data ThunkSource
114 | ThunkSource_Git GitSource
94 | ThunkSource_Git GitSource
115 deriving (Show, Eq, Ord)
95 deriving (Show, Eq, Ord)
97+thunkSourceToGitSource :: ThunkSource -> GitSource
98+thunkSourceToGitSource = \case
99+ ThunkSource_GitHub s -> forgetGithub False s
100+ ThunkSource_Git s -> s
117data GitHubSource = GitHubSource
102data GitHubSource = GitHubSource
118 { _gitHubSource_owner :: Name Owner
103 { _gitHubSource_owner :: Name Owner
119 , _gitHubSource_repo :: Name Repo
104 , _gitHubSource_repo :: Name Repo
@@ -193,14 +178,14 @@ getNixSha256ForUriUnpacked
193getNixSha256ForUriUnpacked uri =
178getNixSha256ForUriUnpacked uri =
194 withExitFailMessage ("nix-prefetch-url: Failed to determine sha256 hash of URL " <> gitUriToText uri) $ do
179 withExitFailMessage ("nix-prefetch-url: Failed to determine sha256 hash of URL " <> gitUriToText uri) $ do
195 [hash] <- fmap T.lines $ readProcessAndLogOutput (Debug, Debug) $
180 [hash] <- fmap T.lines $ readProcessAndLogOutput (Debug, Debug) $
196− proc "nix-prefetch-url" ["--unpack", "--type", "sha256", T.unpack $ gitUriToText uri]
181+ proc nixPrefetchUrlPath ["--unpack", "--type", "sha256", T.unpack $ gitUriToText uri]
197 pure hash
182 pure hash
199nixPrefetchGit :: MonadObelisk m => GitUri -> Text -> Bool -> m NixSha256
184nixPrefetchGit :: MonadObelisk m => GitUri -> Text -> Bool -> m NixSha256
200nixPrefetchGit uri rev fetchSubmodules =
185nixPrefetchGit uri rev fetchSubmodules =
201 withExitFailMessage ("nix-prefetch-git: Failed to determine sha256 hash of Git repo " <> gitUriToText uri <> " at " <> rev) $ do
186 withExitFailMessage ("nix-prefetch-git: Failed to determine sha256 hash of Git repo " <> gitUriToText uri <> " at " <> rev) $ do
202 out <- readProcessAndLogStderr Debug $
187 out <- readProcessAndLogStderr Debug $
203− proc "nix-prefetch-git" $ filter (/="")
188+ proc nixPrefetchGitPath $ filter (/="")
204 [ "--url", T.unpack $ gitUriToText uri
189 [ "--url", T.unpack $ gitUriToText uri
205 , "--rev", T.unpack rev
190 , "--rev", T.unpack rev
206 , if fetchSubmodules then "--fetch-submodules" else ""
191 , if fetchSubmodules then "--fetch-submodules" else ""
@@ -213,96 +198,117 @@ nixPrefetchGit uri rev fetchSubmodules =
214--TODO: Pretty print these
199--TODO: Pretty print these
215data ReadThunkError
200data ReadThunkError
216− = ReadThunkError_UnrecognizedFiles
201+ = ReadThunkError_UnrecognizedThunk
217− | ReadThunkError_AmbiguousFiles
202+ | ReadThunkError_UnrecognizedPaths (NonEmpty FilePath)
218− | ReadThunkError_UnrecognizedLoader Text
203+ | ReadThunkError_MissingPaths (NonEmpty FilePath)
219− | ReadThunkError_UnparseablePtr LBS.ByteString
204+ | ReadThunkError_UnparseablePtr FilePath String
205+ | ReadThunkError_FileError IOError
206+ | ReadThunkError_FileDoesNotMatch FilePath Text
207+ | ReadThunkError_UnrecognizedState String
208+ | ReadThunkError_AmbiguousPackedState ThunkPtr ThunkPtr
220− deriving (Show)
209+ deriving (Show)
222−-- | Read a thunk and validate that it is only a thunk, either packed or unpacked.
211+unpackedDirName :: FilePath
223−-- If the thunk is packed and additional data is present, fail.
212+unpackedDirName = "."
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
235attrCacheFileName :: FilePath
214attrCacheFileName :: FilePath
236attrCacheFileName = ".attr-cache"
215attrCacheFileName = ".attr-cache"
238−data ThunkType = ThunkType
217+-- | Specification for how a file in a thunk version works.
239− { _thunkType_loader :: FilePath
218+data ThunkFileSpec
240− , _thunkType_json :: FilePath
219+ = ThunkFileSpec_Ptr (LBS.ByteString -> Either String ThunkPtr) -- ^ This file specifies 'ThunkPtr' data
241− , _thunkType_optional :: Set FilePath
220+ | ThunkFileSpec_FileMatches Text -- ^ This file must match the given content exactly
242− , _thunkType_loaderVersions :: NonEmpty Text
221+ | ThunkFileSpec_CheckoutIndicator -- ^ Existence of this directory indicates that the thunk is unpacked
243− , _thunkType_parser :: Aeson.Object -> Aeson.Parser ThunkPtr
222+ | ThunkFileSpec_AttrCache -- ^ This directory is an attribute cache
245−
224+-- | Specification for how a set of files in a thunk version work.
246−gitHubThunkType :: ThunkType
225+data ThunkSpec = ThunkSpec
247−gitHubThunkType = ThunkType
226+ { _thunkSpec_name :: !Text
248− { _thunkType_loader = "default.nix"
227+ , _thunkSpec_files :: !(Map FilePath ThunkFileSpec)
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
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
265−thunkTypes :: [ThunkType]
230+thunkSpecTypes :: NonEmpty (NonEmpty ThunkSpec)
266−thunkTypes = [gitThunkType, gitHubThunkType]
231+thunkSpecTypes = gitThunkSpecs :| [gitHubThunkSpecs]
268−findThunkType :: [ThunkType] -> FilePath -> IO (Either ReadThunkError ThunkType)
233+-- | Attempts to match a 'ThunkSpec' to a given directory.
269−findThunkType types thunkDir = do
234+matchThunkSpecToDir
270− matches <- fmap catMaybes $ forM types $ \thunkType -> do
235+ :: (MonadError ReadThunkError m, MonadIO m, MonadCatch m)
271− let
236+ => ThunkSpec -- ^ 'ThunkSpec' to match against the given files/directory
272− expectedContents = Set.fromList $ (thunkDir </>) <$>
237+ -> FilePath -- ^ Path to directory
273− [ _thunkType_loader thunkType
238+ -> Set FilePath -- ^ Set of file paths relative to the given directory
274− , _thunkType_json thunkType
239+ -> m ThunkData
275− ]
240+matchThunkSpecToDir thunkSpec dir dirFiles = do
276− optionalContents = Set.map (thunkDir </>) (_thunkType_optional thunkType)
241+ case nonEmpty (toList $ dirFiles `Set.difference` expectedPaths) of
277−
242+ Just fs -> throwError $ ReadThunkError_UnrecognizedPaths $ (dir </>) <$> fs
278− -- Ensure that there aren't any other files in the thunk
243+ Nothing -> pure ()
279− -- NB: System.Directory.listDirectory returns the contents without the directory path
244+ case nonEmpty (toList $ requiredPaths `Set.difference` dirFiles) of
280− files <- liftIO $ Set.fromList . fmap (thunkDir </>) <$> listDirectory thunkDir
245+ Just fs -> throwError $ ReadThunkError_MissingPaths $ (dir </>) <$> fs
281− let unexpectedContents = files `Set.difference` (expectedContents `Set.union` optionalContents)
246+ Nothing -> pure ()
282− missingContents = expectedContents `Set.difference` files
247+ datas <- fmap toList $ flip Map.traverseMaybeWithKey (_thunkSpec_files thunkSpec) $ \expectedPath -> \case
283− pure $ if Set.null unexpectedContents && Set.null missingContents
248+ ThunkFileSpec_AttrCache -> Nothing <$ dirMayExist expectedPath
284− then Just thunkType
249+ ThunkFileSpec_CheckoutIndicator -> liftIO (doesDirectoryExist (dir </> expectedPath)) <&> \case
285− else Nothing
250+ False -> Nothing
286−
251+ True -> Just ThunkData_Checkout
287− pure $ case matches of
252+ ThunkFileSpec_FileMatches expectedContents -> handle (\(e :: IOError) -> throwError $ ReadThunkError_FileError e) $ do
288− [singleMatch] -> Right singleMatch
253+ actualContents <- liftIO (T.readFile $ dir </> expectedPath)
289− [] -> Left ReadThunkError_UnrecognizedFiles
254+ case T.strip expectedContents == T.strip actualContents of
290− _ -> Left ReadThunkError_AmbiguousFiles
255+ True -> pure Nothing
256+ False -> throwError $ ReadThunkError_FileDoesNotMatch (dir </> expectedPath) expectedContents
257+ ThunkFileSpec_Ptr parser -> handle (\(e :: IOError) -> throwError $ ReadThunkError_FileError e) $ do
258+ let path = dir </> expectedPath
259+ liftIO (doesFileExist path) >>= \case
260+ False -> pure Nothing
262+ actualContents <- liftIO $ LBS.readFile path
263+ case parser actualContents of
264+ Right v -> pure $ Just (ThunkData_Packed thunkSpec v)
265+ Left e -> throwError $ ReadThunkError_UnparseablePtr (dir </> expectedPath) e
267+ case nonEmpty datas of
268+ Nothing -> throwError ReadThunkError_UnrecognizedThunk
269+ Just xs -> fold1WithM xs $ \a b -> either throwError pure (mergeThunkData a b)
271+ rootPathsOnly = Set.fromList . mapMaybe takeRootDir . Map.keys
272+ takeRootDir = fmap NonEmpty.head . nonEmpty . splitPath
274+ expectedPaths = rootPathsOnly $ _thunkSpec_files thunkSpec
276+ requiredPaths = rootPathsOnly $ Map.filter isRequiredFileSpec $ _thunkSpec_files thunkSpec
277+ isRequiredFileSpec = \case
278+ ThunkFileSpec_FileMatches _ -> True
281+ dirMayExist expectedPath = liftIO (doesFileExist (dir </> expectedPath)) >>= \case
282+ True -> throwError $ ReadThunkError_UnrecognizedPaths $ expectedPath :| []
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"
294+ fold1WithM (x :| xs) f = foldM f x xs
298+ => NonEmpty (NonEmpty ThunkSpec) -> FilePath -> m (Either ReadThunkError ThunkData)
299+readThunkWith specTypes dir = do
300+ 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
302+ flip fix specs $ \loop -> \case
303+ [] -> pure $ Left ReadThunkError_UnrecognizedThunk
304+ 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
306+ x@(Right _) -> x <$ putLog Debug [i|Thunk specification ${_thunkSpec_name spec} matched ${dir}|]
292-- | Read a thunk and validate that it is exactly a packed thunk.
308-- | Read a thunk and validate that it is exactly a packed thunk.
293-- If additional data is present, fail.
309-- If additional data is present, fail.
294−readPackedThunk :: FilePath -> IO (Either ReadThunkError ThunkPtr)
310+readThunk :: (MonadObelisk m) => FilePath -> m (Either ReadThunkError ThunkData)
295−readPackedThunk thunkDir = runExceptT $ do
311+readThunk = readThunkWith thunkSpecTypes
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
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
307parseThunkPtr :: (Aeson.Object -> Aeson.Parser ThunkSource) -> Aeson.Object -> Aeson.Parser ThunkPtr
313parseThunkPtr :: (Aeson.Object -> Aeson.Parser ThunkSource) -> Aeson.Object -> Aeson.Parser ThunkPtr
308parseThunkPtr parseSrc v = do
314parseThunkPtr parseSrc v = do
@@ -346,16 +352,18 @@ parseGitSource v = do
346overwriteThunk :: MonadObelisk m => FilePath -> ThunkPtr -> m ()
352overwriteThunk :: MonadObelisk m => FilePath -> ThunkPtr -> m ()
347overwriteThunk target thunk = do
353overwriteThunk target thunk = do
348 -- Ensure that this directory is a valid thunk (i.e. so we aren't losing any data)
354 -- Ensure that this directory is a valid thunk (i.e. so we aren't losing any data)
349− Right _ <- readThunk target
355+ readThunk target >>= \case
356+ Left e -> failWith [i|Invalid thunk at ${target}: ${e}|]
351 --TODO: Is there a safer way to do this overwriting?
359 --TODO: Is there a safer way to do this overwriting?
352− liftIO $ removeDirectoryRecursive target
360+ liftIO $ removePathForcibly target
353− liftIO $ createThunk target thunk
361+ createThunk target $ Right thunk
355−thunkPtrLoader :: ThunkPtr -> Text
363+thunkPtrToSpec :: ThunkPtr -> ThunkSpec
356−thunkPtrLoader thunk = case _thunkPtr_source thunk of
364+thunkPtrToSpec thunk = case _thunkPtr_source thunk of
357− ThunkSource_GitHub _ -> NonEmpty.head gitHubStandaloneLoaders
365+ ThunkSource_GitHub _ -> NonEmpty.head gitHubThunkSpecs
358− ThunkSource_Git _ -> NonEmpty.head plainGitStandaloneLoaders
366+ ThunkSource_Git _ -> NonEmpty.head gitThunkSpecs
360-- It's important that formatting be very consistent here, because
368-- It's important that formatting be very consistent here, because
361-- otherwise when people update thunks, their patches will be messy
369-- otherwise when people update thunks, their patches will be messy
@@ -402,35 +410,41 @@ encodeThunkPtrData (ThunkPtr rev src) = case src of
402 , confTrailingNewline = True
410 , confTrailingNewline = True
405−createThunk :: MonadIO m => FilePath -> ThunkPtr -> m ()
413+createThunk :: MonadObelisk m => FilePath -> Either ThunkSpec ThunkPtr -> m ()
406−createThunk target thunk = liftIO $ do
414+createThunk target ptrInfo =
407− createDirectoryIfMissing True (target </> attrCacheFileName)
415+ ifor_ (_thunkSpec_files spec) $ \path -> \case
408− T.writeFile (target </> "default.nix") (thunkPtrLoader thunk)
416+ ThunkFileSpec_FileMatches content -> withReadyPath path $ \p -> liftIO $ T.writeFile p content
409− let
417+ ThunkFileSpec_Ptr _ -> case ptrInfo of
410− jsonFileName = case _thunkPtr_source thunk of
418+ Left _ -> pure () -- We can't write the ptr without it
411− ThunkSource_GitHub _ -> "github"
419+ Right ptr -> withReadyPath path $ \p -> liftIO $ LBS.writeFile p (encodeThunkPtrData ptr)
412− ThunkSource_Git _ -> "git"
420+ _ -> pure ()
413− LBS.writeFile (target </> jsonFileName <.> "json") (encodeThunkPtrData thunk)
421+ where
422+ spec = either id thunkPtrToSpec ptrInfo
423+ withReadyPath path f = do
424+ let fullPath = target </> path
425+ putLog Debug $ "Writing thunk file " <> T.pack fullPath
426+ liftIO $ createDirectoryIfMissing True $ takeDirectory fullPath
415createThunkWithLatest :: MonadObelisk m => FilePath -> ThunkSource -> m ()
429createThunkWithLatest :: MonadObelisk m => FilePath -> ThunkSource -> m ()
416createThunkWithLatest target s = do
430createThunkWithLatest target s = do
417 rev <- getLatestRev s
431 rev <- getLatestRev s
418− createThunk target $ ThunkPtr
432+ createThunk target $ Right $ ThunkPtr
419 { _thunkPtr_source = s
433 { _thunkPtr_source = s
420 , _thunkPtr_rev = rev
434 , _thunkPtr_rev = rev
423updateThunkToLatest :: MonadObelisk m => ThunkUpdateConfig -> FilePath -> m ()
437updateThunkToLatest :: 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
438+updateThunkToLatest (ThunkUpdateConfig mBranch thunkConfig) target = spinner $ do
425− checkThunkDirectory "ob thunk update directory cannot be '.'" target
439+ checkThunkDirectory target
426 -- check to see if thunk should be updated to a specific branch or just update it's current branch
440 -- check to see if thunk should be updated to a specific branch or just update it's current branch
427 case mBranch of
441 case mBranch of
428 Nothing -> do
442 Nothing -> do
429 (overwrite, ptr) <- readThunk target >>= \case
443 (overwrite, ptr) <- readThunk target >>= \case
430− Left err -> failWith $ T.pack $ "thunk update: " <> show err
444+ Left err -> failWith [i|Thunk update: ${err}|]
431 Right c -> case c of
445 Right c -> case c of
432− ThunkData_Packed t -> return (target, t)
446+ ThunkData_Packed _ t -> return (target, t)
433− ThunkData_Checkout _ -> failWith "cannot update an unpacked thunk"
447+ ThunkData_Checkout -> failWith "cannot update an unpacked thunk"
434 let src = _thunkPtr_source ptr
448 let src = _thunkPtr_source ptr
435 rev <- getLatestRev src
449 rev <- getLatestRev src
436 overwriteThunk overwrite $ modifyThunkPtrByConfig thunkConfig $ ThunkPtr
450 overwriteThunk overwrite $ modifyThunkPtrByConfig thunkConfig $ ThunkPtr
@@ -438,14 +452,12 @@ updateThunkToLatest (ThunkUpdateConfig mBranch thunkConfig) target = withSpinner
438 , _thunkPtr_rev = rev
452 , _thunkPtr_rev = rev
440 Just branch -> readThunk target >>= \case
454 Just branch -> readThunk target >>= \case
441− Left err -> failWith $ T.pack $ "thunk update: " <> show err
455+ Left err -> failWith [i|Thunk update: ${err}|]
442 Right c -> case c of
456 Right c -> case c of
443− ThunkData_Packed t -> case _thunkPtr_source t of
457+ ThunkData_Packed _ t -> setThunk thunkConfig target (thunkSourceToGitSource $ _thunkPtr_source t) branch
444− ThunkSource_Git tsg -> 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.|]
445− ThunkSource_GitHub tsgh -> do
459+ where
446− let tsg = forgetGithub False tsgh
460+ spinner = withSpinner' ("Updating thunk " <> T.pack target <> " to latest") (pure $ const $ "Thunk " <> T.pack target <> " updated to latest")
447− 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."
450setThunk :: MonadObelisk m => ThunkConfig -> FilePath -> GitSource -> String -> m ()
462setThunk :: MonadObelisk m => ThunkConfig -> FilePath -> GitSource -> String -> m ()
451setThunk thunkConfig target gs branch = do
463setThunk thunkConfig target gs branch = do
@@ -455,21 +467,21 @@ setThunk thunkConfig target gs branch = do
456-- | All recognized github standalone loaders, ordered from newest to oldest.
468-- | All recognized github standalone loaders, ordered from newest to oldest.
457-- This tool will only ever produce the newest one when it writes a thunk.
469-- This tool will only ever produce the newest one when it writes a thunk.
458−gitHubStandaloneLoaders :: NonEmpty Text
470+gitHubThunkSpecs :: NonEmpty ThunkSpec
459−gitHubStandaloneLoaders =
471+gitHubThunkSpecs =
460− gitHubStandaloneLoaderV4 :|
472+ gitHubThunkSpecV5 :|
461− [ gitHubStandaloneLoaderV3
473+ [ gitHubThunkSpecV4
462− , gitHubStandaloneLoaderV2
474+ , gitHubThunkSpecV3
463− , gitHubStandaloneLoaderV1
475+ , gitHubThunkSpecV2
466−gitHubStandaloneLoaderV1 :: Text
479+gitHubThunkSpecV1 :: ThunkSpec
467−gitHubStandaloneLoaderV1 = T.unlines
480+gitHubThunkSpecV1 = legacyGitHubThunkSpec "github-v1"
468− [ "import ((import <nixpkgs> {}).fetchFromGitHub (builtins.fromJSON (builtins.readFile ./github.json)))"
481+ "import ((import <nixpkgs> {}).fetchFromGitHub (builtins.fromJSON (builtins.readFile ./github.json)))"
471−gitHubStandaloneLoaderV2 :: Text
483+gitHubThunkSpecV2 :: ThunkSpec
472−gitHubStandaloneLoaderV2 = T.unlines
484+gitHubThunkSpecV2 = legacyGitHubThunkSpec "github-v2" $ T.unlines
473 [ "# DO NOT HAND-EDIT THIS FILE" --TODO: Add something about how to get more info on Obelisk, etc.
485 [ "# DO NOT HAND-EDIT THIS FILE" --TODO: Add something about how to get more info on Obelisk, etc.
474 , "import ((import <nixpkgs> {}).fetchFromGitHub ("
486 , "import ((import <nixpkgs> {}).fetchFromGitHub ("
475 , " let json = builtins.fromJSON (builtins.readFile ./github.json);"
487 , " let json = builtins.fromJSON (builtins.readFile ./github.json);"
@@ -479,8 +491,8 @@ gitHubStandaloneLoaderV2 = T.unlines
482−gitHubStandaloneLoaderV3 :: Text
494+gitHubThunkSpecV3 :: ThunkSpec
483−gitHubStandaloneLoaderV3 = T.unlines
495+gitHubThunkSpecV3 = legacyGitHubThunkSpec "github-v3" $ T.unlines
484 [ "# DO NOT HAND-EDIT THIS FILE"
496 [ "# DO NOT HAND-EDIT THIS FILE"
486 , " fetch = { private ? false, ... }@args: if private && builtins.hasAttr \"fetchGit\" builtins"
498 , " fetch = { private ? false, ... }@args: if private && builtins.hasAttr \"fetchGit\" builtins"
@@ -499,8 +511,8 @@ gitHubStandaloneLoaderV3 = T.unlines
499 , "in import (fetch (builtins.fromJSON (builtins.readFile ./github.json)))"
511 , "in import (fetch (builtins.fromJSON (builtins.readFile ./github.json)))"
502−gitHubStandaloneLoaderV4 :: Text
514+gitHubThunkSpecV4 :: ThunkSpec
503−gitHubStandaloneLoaderV4 = T.unlines
515+gitHubThunkSpecV4 = legacyGitHubThunkSpec "github-v4" $ T.unlines
504 [ "# DO NOT HAND-EDIT THIS FILE"
516 [ "# DO NOT HAND-EDIT THIS FILE"
505 , "let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }:"
517 , "let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }:"
506 , " if !fetchSubmodules && !private then builtins.fetchTarball {"
518 , " if !fetchSubmodules && !private then builtins.fetchTarball {"
@@ -511,24 +523,50 @@ gitHubStandaloneLoaderV4 = T.unlines
511 , "in import (fetch (builtins.fromJSON (builtins.readFile ./github.json)))"
523 , "in import (fetch (builtins.fromJSON (builtins.readFile ./github.json)))"
514−plainGitStandaloneLoaders :: NonEmpty Text
526+legacyGitHubThunkSpec :: Text -> Text -> ThunkSpec
515−plainGitStandaloneLoaders =
527+legacyGitHubThunkSpec name loader = ThunkSpec name $ Map.fromList
516− plainGitStandaloneLoaderV4 :|
528+ [ ("default.nix", ThunkFileSpec_FileMatches $ T.strip loader)
517− [ plainGitStandaloneLoaderV1
529+ , ("github.json" , ThunkFileSpec_Ptr parseGitHubJsonBytes)
518− , plainGitStandaloneLoaderV2
530+ , (attrCacheFileName, ThunkFileSpec_AttrCache)
519− , plainGitStandaloneLoaderV3
531+ , (".git", ThunkFileSpec_CheckoutIndicator)
522−plainGitStandaloneLoaderV1 :: Text
534+gitHubThunkSpecV5 :: ThunkSpec
523−plainGitStandaloneLoaderV1 = T.unlines
535+gitHubThunkSpecV5 = mkThunkSpec "github-v5" "github.json" parseGitHubJsonBytes [here|
536+# DO NOT HAND-EDIT THIS FILE
537+let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }:
538+ if !fetchSubmodules && !private then builtins.fetchTarball {
539+ url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256;
540+ } else (import <nixpkgs> {}).fetchFromGitHub {
541+ inherit owner repo rev sha256 fetchSubmodules private;
543+ json = builtins.fromJSON (builtins.readFile ./github.json);
547+parseGitHubJsonBytes :: LBS.ByteString -> Either String ThunkPtr
548+parseGitHubJsonBytes = parseJsonObject $ parseThunkPtr $ \v ->
549+ ThunkSource_GitHub <$> parseGitHubSource v <|> ThunkSource_Git <$> parseGitSource v
551+gitThunkSpecs :: NonEmpty ThunkSpec
560+gitThunkSpecV1 :: ThunkSpec
561+gitThunkSpecV1 = legacyGitThunkSpec "git-v1" $ T.unlines
524 [ "# DO NOT HAND-EDIT THIS FILE"
562 [ "# DO NOT HAND-EDIT THIS FILE"
525 , "let fetchGit = {url, rev, ref ? null, branch ? null, sha256 ? null, fetchSubmodules ? null}:"
563 , "let fetchGit = {url, rev, ref ? null, branch ? null, sha256 ? null, fetchSubmodules ? null}:"
526 , " assert !fetchSubmodules; (import <nixpkgs> {}).fetchgit { inherit url rev sha256; };"
564 , " assert !fetchSubmodules; (import <nixpkgs> {}).fetchgit { inherit url rev sha256; };"
527 , "in import (fetchGit (builtins.fromJSON (builtins.readFile ./git.json)))"
565 , "in import (fetchGit (builtins.fromJSON (builtins.readFile ./git.json)))"
530−plainGitStandaloneLoaderV2 :: Text
568+gitThunkSpecV2 :: ThunkSpec
531−plainGitStandaloneLoaderV2 = T.unlines
569+gitThunkSpecV2 = legacyGitThunkSpec "git-v2" $ T.unlines
532 [ "# DO NOT HAND-EDIT THIS FILE"
570 [ "# DO NOT HAND-EDIT THIS FILE"
533 , "let fetchGit = {url, rev, ref ? null, branch ? null, sha256 ? null, fetchSubmodules ? null}:"
571 , "let fetchGit = {url, rev, ref ? null, branch ? null, sha256 ? null, fetchSubmodules ? null}:"
534 , " if builtins.hasAttr \"fetchGit\" builtins"
572 , " if builtins.hasAttr \"fetchGit\" builtins"
@@ -539,8 +577,8 @@ plainGitStandaloneLoaderV2 = T.unlines
540-- This loader has a bug because @builtins.fetchGit@ is not given a @ref@
578-- This loader has a bug because @builtins.fetchGit@ is not given a @ref@
541-- and will fail to find commits without this because it does shallow clones.
579-- and will fail to find commits without this because it does shallow clones.
542−plainGitStandaloneLoaderV3 :: Text
580+gitThunkSpecV3 :: ThunkSpec
543−plainGitStandaloneLoaderV3 = T.unlines
581+gitThunkSpecV3 = legacyGitThunkSpec "git-v3" $ T.unlines
544 [ "# DO NOT HAND-EDIT THIS FILE"
582 [ "# DO NOT HAND-EDIT THIS FILE"
545 , "let fetch = {url, rev, ref ? null, sha256 ? null, fetchSubmodules ? false, private ? false, ...}:"
583 , "let fetch = {url, rev, ref ? null, sha256 ? null, fetchSubmodules ? false, private ? false, ...}:"
546 , " let realUrl = let firstChar = builtins.substring 0 1 url; in"
584 , " let realUrl = let firstChar = builtins.substring 0 1 url; in"
@@ -555,8 +593,8 @@ plainGitStandaloneLoaderV3 = T.unlines
555 , "in import (fetch (builtins.fromJSON (builtins.readFile ./git.json)))"
593 , "in import (fetch (builtins.fromJSON (builtins.readFile ./git.json)))"
558−plainGitStandaloneLoaderV4 :: Text
596+gitThunkSpecV4 :: ThunkSpec
559−plainGitStandaloneLoaderV4 = T.unlines
597+gitThunkSpecV4 = legacyGitThunkSpec "git-v4" $ T.unlines
560 [ "# DO NOT HAND-EDIT THIS FILE"
598 [ "# DO NOT HAND-EDIT THIS FILE"
561 , "let fetch = {url, rev, branch ? null, sha256 ? null, fetchSubmodules ? false, private ? false, ...}:"
599 , "let fetch = {url, rev, branch ? null, sha256 ? null, fetchSubmodules ? false, private ? false, ...}:"
562 , " let realUrl = let firstChar = builtins.substring 0 1 url; in"
600 , " let realUrl = let firstChar = builtins.substring 0 1 url; in"
@@ -572,10 +610,52 @@ plainGitStandaloneLoaderV4 = T.unlines
572 , "in import (fetch (builtins.fromJSON (builtins.readFile ./git.json)))"
610 , "in import (fetch (builtins.fromJSON (builtins.readFile ./git.json)))"
575−thunkFileNames :: [FilePath]
613+legacyGitThunkSpec :: Text -> Text -> ThunkSpec
576−thunkFileNames = ["default.nix", "github.json", "git.json"]
614+legacyGitThunkSpec name loader = ThunkSpec name $ Map.fromList
615+ [ ("default.nix", ThunkFileSpec_FileMatches $ T.strip loader)
616+ , ("git.json" , ThunkFileSpec_Ptr parseGitJsonBytes)
617+ , (attrCacheFileName, ThunkFileSpec_AttrCache)
618+ , (".git", ThunkFileSpec_CheckoutIndicator)
621+gitThunkSpecV5 :: ThunkSpec
622+gitThunkSpecV5 = mkThunkSpec "git-v5" "git.json" parseGitJsonBytes [here|
623+# DO NOT HAND-EDIT THIS FILE
624+let fetch = {url, rev, branch ? null, sha256 ? null, fetchSubmodules ? false, private ? false, ...}:
625+ let realUrl = let firstChar = builtins.substring 0 1 url; in
626+ if firstChar == "/" then /. + url
627+ else if firstChar == "." then ./. + url
629+ in if !fetchSubmodules && private then builtins.fetchGit {
630+ url = realUrl; inherit rev;
631+ ${if branch == null then null else "ref"} = branch;
632+ } else (import <nixpkgs> {}).fetchgit {
633+ url = realUrl; inherit rev sha256;
635+ json = builtins.fromJSON (builtins.readFile ./git.json);
639+parseGitJsonBytes :: LBS.ByteString -> Either String ThunkPtr
640+parseGitJsonBytes = parseJsonObject $ parseThunkPtr $ fmap ThunkSource_Git . parseGitSource
642+mkThunkSpec :: Text -> FilePath -> (LBS.ByteString -> Either String ThunkPtr) -> Text -> ThunkSpec
643+mkThunkSpec name jsonFileName parser srcNix = ThunkSpec name $ Map.fromList
644+ [ ("default.nix", ThunkFileSpec_FileMatches defaultNixViaSrc)
645+ , ("thunk.nix", ThunkFileSpec_FileMatches srcNix)
646+ , (jsonFileName, ThunkFileSpec_Ptr parser)
647+ , (attrCacheFileName, ThunkFileSpec_AttrCache)
648+ , (normalise $ unpackedDirName </> ".git", ThunkFileSpec_CheckoutIndicator)
651+ defaultNixViaSrc = [here|
652+# DO NOT HAND-EDIT THIS FILE
653+import (import ./thunk.nix)
578−--TODO: when checking something out, make a shallow clone
656+
657+parseJsonObject :: (Aeson.Object -> Aeson.Parser a) -> LBS.ByteString -> Either String a
658+parseJsonObject p bytes = Aeson.parseEither p =<< Aeson.eitherDecode bytes
580-- | Checks a cache directory to see if there is a fresh symlink
660-- | Checks a cache directory to see if there is a fresh symlink
581-- to the result of building an attribute of a thunk.
661-- to the result of building an attribute of a thunk.
@@ -583,44 +663,49 @@ thunkFileNames = ["default.nix", "github.json", "git.json"]
583-- and the result is symlinked into the cache.
663-- and the result is symlinked into the cache.
584nixBuildThunkAttrWithCache
664nixBuildThunkAttrWithCache
585 :: MonadObelisk m
665 :: MonadObelisk m
586− => FilePath
666+ => ThunkSpec
587 -- ^ Path to directory containing Thunk
668 -- ^ Path to directory containing Thunk
588 -> String
669 -> String
589 -- ^ Attribute to build
670 -- ^ Attribute to build
590− -> m FilePath
671+ -> m (Maybe FilePath)
591 -- ^ Symlink to cached or built nix output
672 -- ^ Symlink to cached or built nix output
592-- WARNING: If the thunk uses an impure reference such as '<nixpkgs>'
673-- WARNING: If the thunk uses an impure reference such as '<nixpkgs>'
593-- the caching mechanism will fail as it merely measures the modification
674-- the caching mechanism will fail as it merely measures the modification
594-- time of the cache link and the expression to build.
675-- time of the cache link and the expression to build.
595−nixBuildThunkAttrWithCache thunkDir attr = do
676+nixBuildThunkAttrWithCache thunkSpec 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"
603 latestChange <- liftIO $ do
677 latestChange <- liftIO $ do
604− createDirectoryIfMissing False cacheDir
678+ let
605− let getModificationTimeMaybe = fmap rightToMaybe . try @IOError . getModificationTime
679+ getModificationTimeMaybe = fmap rightToMaybe . try @IOError . getModificationTime
606− maximum . catMaybes <$> mapM (getModificationTimeMaybe . (thunkDir </>)) thunkFileNames
680+ thunkFileNames = Map.keys $ _thunkSpec_files thunkSpec
607− cacheHit <- handle cacheErrHandler $ do
681+ maximum . catMaybes <$> traverse (getModificationTimeMaybe . (thunkDir </>)) thunkFileNames
608− cacheTime <- liftIO $ posixSecondsToUTCTime . realToFrac . modificationTime <$> getSymbolicLinkStatus cachePath
682+
609− return $ if latestChange <= cacheTime
683+ let cachePaths' = nonEmpty $ Map.keys $ Map.filter (\case ThunkFileSpec_AttrCache -> True; _ -> False) $
610− then Just cachePath
684+ _thunkSpec_files thunkSpec
611− else Nothing
685+ for cachePaths' $ \cachePaths ->
612− case cacheHit of
686+ fmap NonEmpty.head $ for cachePaths $ \cacheDir -> do
613− Just c -> return c
687+ let
614− Nothing -> do
688+ cachePath = thunkDir </> cacheDir </> attr <.> "out"
615− putLog Warning $ T.pack $ mconcat [thunkDir, ": ", attr, " not cached, building ..."]
689+ cacheErrHandler e
616− _ <- nixCmd $ NixCmd_Build $ def
690+ | isDoesNotExistError e = pure Nothing -- expected from a cache miss
617− Lens.& nixBuildConfig_outLink Lens..~ OutLink_IndirectRoot cachePath
691+ | otherwise = Nothing <$ putLog Error (T.pack $ displayException e)
618− Lens.& nixCmdConfig_target Lens..~ Target
692+ cacheHit <- handle cacheErrHandler $ do
619− { _target_path = Just thunkDir
693+ cacheTime <- liftIO $ posixSecondsToUTCTime . realToFrac . modificationTime <$> getSymbolicLinkStatus cachePath
620− , _target_attr = Just attr
694+ pure $ if latestChange <= cacheTime
621− , _target_expr = Nothing
695+ then Just cachePath
623− return cachePath
697+ case cacheHit of
700+ putLog Warning $ T.pack $ mconcat [thunkDir, ": ", attr, " not cached, building ..."]
701+ liftIO $ createDirectoryIfMissing True (takeDirectory cachePath)
702+ (cachePath <$) $ nixCmd $ NixCmd_Build $ def
703+ & nixBuildConfig_outLink .~ OutLink_IndirectRoot cachePath
704+ & nixCmdConfig_target .~ Target
705+ { _target_path = Just thunkDir
706+ , _target_attr = Just attr
707+ , _target_expr = Nothing
625-- | Build a nix attribute, and cache the result if possible
710-- | Build a nix attribute, and cache the result if possible
626nixBuildAttrWithCache
711nixBuildAttrWithCache
@@ -631,13 +716,15 @@ nixBuildAttrWithCache
631 -- ^ Attribute to build
716 -- ^ Attribute to build
632 -> m FilePath
717 -> m FilePath
633 -- ^ Symlink to cached or built nix output
718 -- ^ Symlink to cached or built nix output
634−nixBuildAttrWithCache exprPath attr = do
719+nixBuildAttrWithCache exprPath attr = readThunk exprPath >>= \case
635− readThunk exprPath >>= \case
720+ -- Only packed thunks are cached. In particular, checkouts are not.
636− -- Only packed thunks are cached. in particular, checkouts are not
721+ Right (ThunkData_Packed spec _) ->
637− Right (ThunkData_Packed _) -> nixBuildThunkAttrWithCache exprPath attr
722+ maybe build pure =<< nixBuildThunkAttrWithCache spec exprPath attr
638− _ -> nixCmd $ NixCmd_Build $ def
723+ _ -> build
639− Lens.& nixBuildConfig_outLink Lens..~ OutLink_None
724+ where
640− Lens.& nixCmdConfig_target Lens..~ Target
725+ build = nixCmd $ NixCmd_Build $ def
726+ & nixBuildConfig_outLink .~ OutLink_None
727+ & nixCmdConfig_target .~ Target
641 { _target_path = Just exprPath
728 { _target_path = Just exprPath
642 , _target_attr = Just attr
729 , _target_attr = Just attr
643 , _target_expr = Nothing
730 , _target_expr = Nothing
@@ -658,7 +745,7 @@ updateThunk p f = withSystemTempDirectory "obelisk-thunkptr-" $ \tmpDir -> do
659 copyThunkToTmp tmpDir thunkDir = readThunk thunkDir >>= \case
746 copyThunkToTmp tmpDir thunkDir = readThunk thunkDir >>= \case
660 Left err -> failWith $ "withThunkUnpacked: " <> T.pack (show err)
747 Left err -> failWith $ "withThunkUnpacked: " <> T.pack (show err)
661− Right (ThunkData_Packed _) -> do
748+ Right ThunkData_Packed{} -> do
662 let tmpThunk = tmpDir </> "thunk"
749 let tmpThunk = tmpDir </> "thunk"
663 callProcessAndLogOutput (Notice, Error) $
750 callProcessAndLogOutput (Notice, Error) $
664 proc cp ["-r", "-T", thunkDir, tmpThunk]
751 proc cp ["-r", "-T", thunkDir, tmpThunk]
@@ -672,62 +759,81 @@ updateThunk p f = withSystemTempDirectory "obelisk-thunkptr-" $ \tmpDir -> do
672finalMsg :: Bool -> (a -> Text) -> Maybe (a -> Text)
759finalMsg :: Bool -> (a -> Text) -> Maybe (a -> Text)
673finalMsg noTrail s = if noTrail then Nothing else Just s
760finalMsg noTrail s = if noTrail then Nothing else Just s
675−unpackThunk :: MonadObelisk m => FilePath -> m ()
676−unpackThunk = unpackThunk' False
678-- | Check that we are not somewhere inside the thunk directory
762-- | Check that we are not somewhere inside the thunk directory
679−checkThunkDirectory :: MonadObelisk m => Text -> FilePath -> m ()
763+checkThunkDirectory :: MonadObelisk m => FilePath -> m ()
680−checkThunkDirectory msg thunkDir = do
764+checkThunkDirectory thunkDir = do
681 currentDir <- liftIO getCurrentDirectory
765 currentDir <- liftIO getCurrentDirectory
682 thunkDir' <- liftIO $ canonicalizePath thunkDir
766 thunkDir' <- liftIO $ canonicalizePath thunkDir
683− when (thunkDir' `L.isInfixOf` currentDir) $ failWith msg
767+ when (thunkDir' `L.isInfixOf` currentDir) $
768+ failWith [i|Can't perform thunk operations from within the thunk directory: ${thunkDir}|]
770+ -- Don't let thunk commands work when directly given an unpacked repo
771+ when (takeFileName thunkDir == unpackedDirName) $
772+ readThunk (takeDirectory thunkDir) >>= \case
773+ Right _ -> failWith [i|Refusing to perform thunk operation on ${thunkDir} because it is a thunk's unpacked source|]
776+unpackThunk :: MonadObelisk m => FilePath -> m ()
777+unpackThunk = unpackThunk' False
685unpackThunk' :: MonadObelisk m => Bool -> FilePath -> m ()
779unpackThunk' :: MonadObelisk m => Bool -> FilePath -> m ()
686−unpackThunk' noTrail thunkDir = checkThunkDirectory "Can't pack/unpack from within the thunk directory" thunkDir >> readThunk thunkDir >>= \case
780+unpackThunk' noTrail thunkDir = checkThunkDirectory thunkDir *> readThunk thunkDir >>= \case
687− Left err -> failWith $ "thunk unpack: " <> T.pack (show err)
781+ Left err -> failWith [i|Invalid thunk at ${thunkDir}: ${err}|]
688 --TODO: Overwrite option that rechecks out thunk; force option to do so even if working directory is dirty
782 --TODO: Overwrite option that rechecks out thunk; force option to do so even if working directory is dirty
689− Right (ThunkData_Checkout _) -> failWith "thunk unpack: thunk is already unpacked"
783+ Right ThunkData_Checkout -> failWith [i|Thunk at ${thunkDir} is already unpacked|]
690− Right (ThunkData_Packed tptr) -> do
784+ Right (ThunkData_Packed _ tptr) -> do
691 let (thunkParent, thunkName) = splitFileName thunkDir
785 let (thunkParent, thunkName) = splitFileName thunkDir
692− withTempDirectory thunkParent thunkName $ \tmpRepo -> do
786+ withTempDirectory thunkParent thunkName $ \tmpThunk -> do
693− let obGitDir = tmpRepo </> ".git" </> "obelisk"
787+ let
694− s = case _thunkPtr_source tptr of
788+ gitSrc = thunkSourceToGitSource $ _thunkPtr_source tptr
695− ThunkSource_GitHub s' -> forgetGithub False s'
789+ newSpec = case _thunkPtr_source tptr of
696− ThunkSource_Git s' -> s'
790+ ThunkSource_GitHub _ -> NonEmpty.head gitHubThunkSpecs
791+ ThunkSource_Git _ -> NonEmpty.head gitThunkSpecs
697 withSpinner' ("Fetching thunk " <> T.pack thunkName)
792 withSpinner' ("Fetching thunk " <> T.pack thunkName)
698 (finalMsg noTrail $ const $ "Fetched thunk " <> T.pack thunkName) $ do
793 (finalMsg noTrail $ const $ "Fetched thunk " <> T.pack thunkName) $ do
699− let git = callProcessAndLogOutput (Notice, Notice) . gitProc tmpRepo
794+ let unpackedPath = tmpThunk </> unpackedDirName
700− git $ [ "clone" ]
795+ gitCloneForThunkUnpack gitSrc (_thunkRev_commit $ _thunkPtr_rev tptr) unpackedPath
701− ++ ("--recursive" <$ guard (_gitSource_fetchSubmodules s))
796+
702− ++ [ T.unpack $ gitUriToText $ _gitSource_url s ]
797+ let normalizeMore = dropTrailingPathSeparator . normalise
703− ++ do branch <- maybeToList $ _gitSource_branch s
798+ when (normalizeMore unpackedPath /= normalizeMore tmpThunk) $ -- Only write meta data if the checkout is not inplace
704− [ "--branch", T.unpack $ untagName branch ]
799+ createThunk tmpThunk $ Left newSpec
705− git ["reset", "--hard", Ref.toHexString $ _thunkRev_commit $ _thunkPtr_rev tptr]
800+
706− when (_gitSource_fetchSubmodules s) $
801+ liftIO $ do
707− git ["submodule", "update", "--recursive", "--init"]
802+ removePathForcibly thunkDir
708−
803+ renameDirectory tmpThunk thunkDir
709− liftIO $ createDirectory obGitDir
804+
710− callProcessAndLogOutput (Notice, Error) $
805+gitCloneForThunkUnpack
711− proc cp ["-r", "-T", thunkDir </> ".", obGitDir </> "orig-thunk"]
806+ :: MonadObelisk m
712− callProcessAndLogOutput (Notice, Error) $
807+ => GitSource -- ^ Git source to use
713− proc "rm" ["-r", thunkDir]
808+ -> Ref hash -- ^ Commit hash to reset to
714− callProcessAndLogOutput (Notice, Error) $
809+ -> FilePath -- ^ Directory to clone into
715− proc "mv" ["-T", tmpRepo, thunkDir]
810+ -> m ()
811+gitCloneForThunkUnpack gitSrc commit dir = do
812+ let git = callProcessAndLogOutput (Notice, Notice) . gitProc dir
814+ ++ ["--recursive" | _gitSource_fetchSubmodules gitSrc]
815+ ++ [ T.unpack $ gitUriToText $ _gitSource_url gitSrc ]
816+ ++ do branch <- maybeToList $ _gitSource_branch gitSrc
817+ [ "--branch", T.unpack $ untagName branch ]
818+ git ["reset", "--hard", Ref.toHexString commit]
819+ when (_gitSource_fetchSubmodules gitSrc) $
820+ git ["submodule", "update", "--recursive", "--init"]
717--TODO: add a rollback mode to pack to the original thunk
822--TODO: add a rollback mode to pack to the original thunk
718packThunk :: MonadObelisk m => ThunkPackConfig -> FilePath -> m ThunkPtr
823packThunk :: MonadObelisk m => ThunkPackConfig -> FilePath -> m ThunkPtr
719packThunk = packThunk' False
824packThunk = packThunk' False
721packThunk' :: MonadObelisk m => Bool -> ThunkPackConfig -> FilePath -> m ThunkPtr
826packThunk' :: 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
827+packThunk' noTrail (ThunkPackConfig force thunkConfig) thunkDir = checkThunkDirectory thunkDir *> readThunk thunkDir >>= \case
723− Left err -> failWith $ T.pack $ "thunk pack: " <> show err
828+ Right ThunkData_Packed{} -> failWith [i|Thunk at ${thunkDir} is is already packed|]
724− Right (ThunkData_Packed _) -> failWith "pack: thunk is already packed"
829+ _ -> withSpinner'
725− Right (ThunkData_Checkout _) -> do
830+ ("Packing thunk " <> T.pack thunkDir)
726− withSpinner' ("Packing thunk " <> T.pack thunkDir)
831+ (finalMsg noTrail $ const $ "Packed thunk " <> T.pack thunkDir) $
727− (finalMsg noTrail $ const $ "Packed thunk " <> T.pack thunkDir) $ do
832+ do
728− thunkPtr <- modifyThunkPtrByConfig thunkConfig <$> getThunkPtr (not force) thunkDir (_thunkConfig_private thunkConfig)
833+ let checkClean = if force then CheckClean_NoCheck else CheckClean_FullCheck
729− callProcessAndLogOutput (Debug, Error) $ proc "rm" ["-rf", thunkDir]
834+ thunkPtr <- modifyThunkPtrByConfig thunkConfig <$> getThunkPtr checkClean thunkDir (_thunkConfig_private thunkConfig)
730− liftIO $ createThunk thunkDir thunkPtr
835+ liftIO $ removePathForcibly thunkDir
836+ createThunk thunkDir $ Right thunkPtr
731 pure thunkPtr
837 pure thunkPtr
733modifyThunkPtrByConfig :: ThunkConfig -> ThunkPtr -> ThunkPtr
839modifyThunkPtrByConfig :: ThunkConfig -> ThunkPtr -> ThunkPtr
@@ -738,29 +844,43 @@ modifyThunkPtrByConfig (ThunkConfig markPrivate') ptr = case markPrivate' of
738 ThunkSource_GitHub s -> ThunkSource_GitHub $ s { _gitHubSource_private = markPrivate }
844 ThunkSource_GitHub s -> ThunkSource_GitHub $ s { _gitHubSource_private = markPrivate }
741−getThunkPtr :: forall m. MonadObelisk m => Bool -> FilePath -> Maybe Bool -> m ThunkPtr
847+data CheckClean
742−getThunkPtr checkClean thunkDir mPrivate = do
848+ = CheckClean_FullCheck
743− when checkClean $ ensureCleanGitRepo thunkDir True
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
856+getThunkPtr gitCheckClean dir mPrivate = do
857+ let repoLocations = nubOrd $ map (first normalise)
858+ [(".git", "."), (unpackedDirName </> ".git", unpackedDirName)]
859+ repoLocation' <- liftIO $ flip findM repoLocations $ doesDirectoryExist . (dir </>) . fst
860+ thunkDir <- case repoLocation' of
861+ Nothing -> failWith [i|Can't find an unpacked thunk in ${dir}|]
862+ Just (_, path) -> pure $ normalise $ dir </> path
864+ let (checkClean, checkIgnored) = case gitCheckClean of
865+ CheckClean_FullCheck -> (True, True)
866+ CheckClean_NotIgnored -> (True, False)
867+ CheckClean_NoCheck -> (False, False)
868+ when checkClean $ ensureCleanGitRepo thunkDir checkIgnored
744 "thunk pack: thunk checkout contains unsaved modifications"
869 "thunk pack: thunk checkout contains unsaved modifications"
746 -- Check whether there are any stashes
871 -- Check whether there are any stashes
747− stashOutput <- readGitProcess thunkDir ["stash", "list"]
872+ when checkClean $ do
748− when checkClean $ case T.null stashOutput of
873+ stashOutput <- readGitProcess thunkDir ["stash", "list"]
749− False -> do
874+ unless (T.null stashOutput) $
750 failWith $ T.unlines $
875 failWith $ T.unlines $
751 [ "thunk pack: thunk checkout has stashes"
876 [ "thunk pack: thunk checkout has stashes"
752 , "git stash list:"
877 , "git stash list:"
753 ] ++ T.lines stashOutput
878 ] ++ T.lines stashOutput
756 -- Get current branch
880 -- Get current branch
757 (mCurrentBranch, mCurrentCommit) <- do
881 (mCurrentBranch, mCurrentCommit) <- do
758− b <- listToMaybe
882+ b <- listToMaybe . T.lines <$> readGitProcess thunkDir ["rev-parse", "--abbrev-ref", "HEAD"]
759− <$> T.lines
883+ c <- listToMaybe . T.lines <$> readGitProcess thunkDir ["rev-parse", "HEAD"]
760− <$> readGitProcess thunkDir ["rev-parse", "--abbrev-ref", "HEAD"]
763− <$> readGitProcess thunkDir ["rev-parse", "HEAD"]
764 case b of
884 case b of
765 (Just "HEAD") -> failWith $ T.unlines
885 (Just "HEAD") -> failWith $ T.unlines
766 [ "thunk pack: You are in 'detached HEAD' state."
886 [ "thunk pack: You are in 'detached HEAD' state."
@@ -771,7 +891,7 @@ getThunkPtr checkClean thunkDir mPrivate = do
772 -- Get information on all branches and their (optional) designated upstream
892 -- Get information on all branches and their (optional) designated upstream
773 -- correspondents
893 -- correspondents
774− (headDump :: [Text]) <- T.lines <$> readGitProcess thunkDir
894+ headDump :: [Text] <- T.lines <$> readGitProcess thunkDir
775 [ "for-each-ref"
895 [ "for-each-ref"
776 , "--format=%(refname:short) %(upstream:short) %(upstream:remotename)"
896 , "--format=%(refname:short) %(upstream:short) %(upstream:remotename)"
777 , "refs/heads/"
897 , "refs/heads/"
@@ -817,7 +937,7 @@ getThunkPtr checkClean thunkDir mPrivate = do
819 -- loosely by https://stackoverflow.com/questions/7773939/show-git-ahead-and-behind-info-for-all-branches-including-remotes
939 -- 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
940+ stats <- ifor headUpstream $ \branch (upstream, _remote) -> do
821 (stat :: [Text]) <- T.lines <$> readGitProcess thunkDir
941 (stat :: [Text]) <- T.lines <$> readGitProcess thunkDir
822 [ "rev-list", "--left-right"
942 [ "rev-list", "--left-right"
823 , T.unpack branch <> "..." <> T.unpack upstream
943 , T.unpack branch <> "..." <> T.unpack upstream
@@ -841,8 +961,9 @@ getThunkPtr checkClean thunkDir mPrivate = do
841 \pushed but this repo's remote tracking branches don't know it.)"
961 \pushed but this repo's remote tracking branches don't know it.)"
844− -- We assume it's safe to pack the thunk at this point
964+ when checkClean $ do
845− putLog Informational "All changes safe in git remotes. OK to pack thunk."
965+ -- 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."
847 let remote = maybe "origin" snd $ flip Map.lookup headUpstream =<< mCurrentBranch
968 let remote = maybe "origin" snd $ flip Map.lookup headUpstream =<< mCurrentBranch
@@ -860,9 +981,7 @@ getThunkPtr checkClean thunkDir mPrivate = do
860-- | Get the latest revision available from the given source
981-- | Get the latest revision available from the given source
861getLatestRev :: MonadObelisk m => ThunkSource -> m ThunkRev
982getLatestRev :: MonadObelisk m => ThunkSource -> m ThunkRev
862getLatestRev os = do
983getLatestRev os = do
863− let gitS = case os of
984+ let gitS = thunkSourceToGitSource os
864− ThunkSource_GitHub s -> forgetGithub False s
865− ThunkSource_Git s -> s
866 (_, commit) <- gitGetCommitBranch (_gitSource_url gitS) (untagName <$> _gitSource_branch gitS)
985 (_, commit) <- gitGetCommitBranch (_gitSource_url gitS) (untagName <$> _gitSource_branch gitS)
867 case os of
986 case os of
868 ThunkSource_GitHub s -> githubThunkRev s commit
987 ThunkSource_GitHub s -> githubThunkRev s commit