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