@@ -5,48 +5,67 @@
55{-# LANGUAGE MultiWayIf #-}
66{-# LANGUAGE OverloadedStrings #-}
77{-# LANGUAGE PatternGuards #-}
8−{-# LANGUAGE QuasiQuotes #-}
98{-# LANGUAGE ScopedTypeVariables #-}
109{-# LANGUAGE TypeApplications #-}
11−module Obelisk.Command.Thunk where
10+module Obelisk.Command.Thunk
11+ ( GitHubSource (..)
12+ , GitUri (..)
13+ , ReadThunkError (..)
14+ , ThunkConfig (..)
15+ , ThunkData (..)
16+ , ThunkPackConfig (..)
17+ , ThunkPtr (..)
18+ , ThunkRev (..)
19+ , ThunkSource (..)
20+ , ThunkUpdateConfig (..)
21+ , attrCacheFileName
22+ , createThunk
23+ , createThunkWithLatest
24+ , getLatestRev
25+ , getThunkGitBranch
26+ , getThunkPtr
27+ , gitUriToText
28+ , nixBuildAttrWithCache
29+ , nixBuildThunkAttrWithCache
30+ , packThunk
31+ , parseGitUri
32+ , readThunk
33+ , unpackThunk
34+ , updateThunk
35+ , updateThunkToLatest
36+ , uriThunkPtr
37+ ) where
1238
1339import Control.Applicative
1440import Control.Exception (displayException, try)
15−import Control.Lens (ifor, ifor_, (.~))
41+import qualified Control.Lens as Lens
42+import Control.Lens.Indexed hiding ((<.>))
1643import Control.Monad
17−import Control.Monad.Extra (findM)
18−import Control.Monad.Catch (MonadCatch, handle)
44+import Control.Monad.Catch (handle)
1945import Control.Monad.Except
2046import Data.Aeson ((.=))
2147import qualified Data.Aeson as Aeson
2248import Data.Aeson.Encode.Pretty
2349import qualified Data.Aeson.Types as Aeson
24−import Data.Bifunctor (first)
2550import qualified Data.ByteString.Lazy as LBS
2651import Data.Containers.ListUtils (nubOrd)
2752import Data.Default
2853import Data.Either.Combinators (fromRight', rightToMaybe)
29−import Data.Foldable (toList)
30−import Data.Function ((&))
31−import Data.Functor ((<&>))
3254import Data.Git.Ref (Ref)
3355import qualified Data.Git.Ref as Ref
3456import qualified Data.List as L
35−import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
57+import Data.List.NonEmpty (NonEmpty (..))
3658import qualified Data.List.NonEmpty as NonEmpty
3759import Data.Map (Map)
3860import qualified Data.Map as Map
3961import Data.Maybe
4062import Data.Set (Set)
4163import qualified Data.Set as Set
42−import Data.String.Here.Interpolated (i)
43−import Data.String.Here.Uninterpolated (here)
4464import Data.Text (Text)
4565import qualified Data.Text as T
4666import Data.Text.Encoding
4767import qualified Data.Text.IO as T
4868import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
49−import Data.Traversable (for)
5069import Data.Yaml (parseMaybe)
5170import GitHub
5271import GitHub.Data.Name
@@ -56,7 +75,7 @@ import System.Exit
5675import System.FilePath
5776import System.IO.Error
5877import System.IO.Temp
59−import System.PosixCompat.Files (getSymbolicLinkStatus, modificationTime)
78+import System.Posix (getSymbolicLinkStatus, modificationTime)
6079import qualified Text.URI as URI
6180
6281import Obelisk.App (MonadObelisk)
@@ -65,10 +84,11 @@ import Obelisk.Command.Utils
6584
6685--TODO: Support symlinked thunk data
6786data ThunkData
68− = ThunkData_Packed ThunkSpec ThunkPtr
87+ = ThunkData_Packed ThunkPtr
6988 -- ^ Packed thunk
70− | ThunkData_Checkout
89+ | ThunkData_Checkout (Maybe ThunkPtr)
7190 -- ^ Checked out thunk that was unpacked from this pointer
91+ deriving (Show, Eq, Ord)
7292
7393-- | A reference to the exact data that a thunk should translate into
7494data ThunkPtr = ThunkPtr
@@ -94,11 +114,6 @@ data ThunkSource
94114 | ThunkSource_Git GitSource
95115 deriving (Show, Eq, Ord)
96116
97−thunkSourceToGitSource :: ThunkSource -> GitSource
98−thunkSourceToGitSource = \case
99− ThunkSource_GitHub s -> forgetGithub False s
100− ThunkSource_Git s -> s
101−
102117data GitHubSource = GitHubSource
103118 { _gitHubSource_owner :: Name Owner
104119 , _gitHubSource_repo :: Name Repo
@@ -178,14 +193,14 @@ getNixSha256ForUriUnpacked
178193getNixSha256ForUriUnpacked uri =
179194 withExitFailMessage ("nix-prefetch-url: Failed to determine sha256 hash of URL " <> gitUriToText uri) $ do
180195 [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]
182197 pure hash
183198
184199nixPrefetchGit :: MonadObelisk m => GitUri -> Text -> Bool -> m NixSha256
185200nixPrefetchGit uri rev fetchSubmodules =
186201 withExitFailMessage ("nix-prefetch-git: Failed to determine sha256 hash of Git repo " <> gitUriToText uri <> " at " <> rev) $ do
187202 out <- readProcessAndLogStderr Debug $
188− proc nixPrefetchGitPath $ filter (/="")
203+ proc "nix-prefetch-git" $ filter (/="")
189204 [ "--url", T.unpack $ gitUriToText uri
190205 , "--rev", T.unpack rev
191206 , if fetchSubmodules then "--fetch-submodules" else ""
@@ -198,117 +213,96 @@ nixPrefetchGit uri rev fetchSubmodules =
198213
199214--TODO: Pretty print these
200215data ReadThunkError
201− = ReadThunkError_UnrecognizedThunk
202− | ReadThunkError_UnrecognizedPaths (NonEmpty FilePath)
203− | ReadThunkError_MissingPaths (NonEmpty FilePath)
204− | ReadThunkError_UnparseablePtr FilePath String
205− | ReadThunkError_FileError IOError
206− | ReadThunkError_FileDoesNotMatch FilePath Text
207− | ReadThunkError_UnrecognizedState String
208− | ReadThunkError_AmbiguousPackedState ThunkPtr ThunkPtr
209− deriving (Show)
210−
211−unpackedDirName :: FilePath
212−unpackedDirName = "."
216+ = ReadThunkError_UnrecognizedFiles
217+ | ReadThunkError_AmbiguousFiles
218+ | ReadThunkError_UnrecognizedLoader Text
219+ | ReadThunkError_UnparseablePtr LBS.ByteString
220+ deriving (Show)
221+
222+-- | Read a thunk and validate that it is only a thunk, either packed or unpacked.
223+-- If the thunk is packed and additional data is present, fail.
224+readThunk :: MonadObelisk m => FilePath -> m (Either ReadThunkError ThunkData)
225+readThunk thunkDir = do
226+ files <- liftIO $ listDirectory thunkDir
227+ case ".git" `elem` files of
228+ True -> fmap ThunkData_Checkout <$> do
229+ let origThunkPath = thunkDir </> ".git" </> "obelisk" </> "orig-thunk"
230+ liftIO $ doesDirectoryExist origThunkPath >>= \case
231+ True -> fmap Just <$> readPackedThunk origThunkPath
232+ False -> return $ return Nothing
233+ False -> liftIO $ fmap ThunkData_Packed <$> readPackedThunk thunkDir
213234
214235attrCacheFileName :: FilePath
215236attrCacheFileName = ".attr-cache"
216237
217−-- | Specification for how a file in a thunk version works.
218−data ThunkFileSpec
219− = ThunkFileSpec_Ptr (LBS.ByteString -> Either String ThunkPtr) -- ^ This file specifies 'ThunkPtr' data
220− | ThunkFileSpec_FileMatches Text -- ^ This file must match the given content exactly
221− | ThunkFileSpec_CheckoutIndicator -- ^ Existence of this directory indicates that the thunk is unpacked
222− | ThunkFileSpec_AttrCache -- ^ This directory is an attribute cache
223−
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)
238+data ThunkType = ThunkType
239+ { _thunkType_loader :: FilePath
240+ , _thunkType_json :: FilePath
241+ , _thunkType_optional :: Set FilePath
242+ , _thunkType_loaderVersions :: NonEmpty Text
243+ , _thunkType_parser :: Aeson.Object -> Aeson.Parser ThunkPtr
228244 }
229245
230−thunkSpecTypes :: NonEmpty (NonEmpty ThunkSpec)
231−thunkSpecTypes = gitThunkSpecs :| [gitHubThunkSpecs]
232−
233−-- | Attempts to match a 'ThunkSpec' to a given directory.
234−matchThunkSpecToDir
235− :: (MonadError ReadThunkError m, MonadIO m, MonadCatch m)
236− => ThunkSpec -- ^ 'ThunkSpec' to match against the given files/directory
237− -> FilePath -- ^ Path to directory
238− -> Set FilePath -- ^ Set of file paths relative to the given directory
239− -> m ThunkData
240−matchThunkSpecToDir thunkSpec dir dirFiles = do
241− case nonEmpty (toList $ dirFiles `Set.difference` expectedPaths) of
242− Just fs -> throwError $ ReadThunkError_UnrecognizedPaths $ (dir </>) <$> fs
243− Nothing -> pure ()
244− case nonEmpty (toList $ requiredPaths `Set.difference` dirFiles) of
245− Just fs -> throwError $ ReadThunkError_MissingPaths $ (dir </>) <$> fs
246− Nothing -> pure ()
247− datas <- fmap toList $ flip Map.traverseMaybeWithKey (_thunkSpec_files thunkSpec) $ \expectedPath -> \case
248− ThunkFileSpec_AttrCache -> Nothing <$ dirMayExist expectedPath
249− ThunkFileSpec_CheckoutIndicator -> liftIO (doesDirectoryExist (dir </> expectedPath)) <&> \case
250− False -> Nothing
251− True -> Just ThunkData_Checkout
252− ThunkFileSpec_FileMatches expectedContents -> handle (\(e :: IOError) -> throwError $ ReadThunkError_FileError e) $ do
253− actualContents <- liftIO (T.readFile $ dir </> expectedPath)
254− case T.strip expectedContents == T.strip actualContents of
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
261− True -> do
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
266−
267− case nonEmpty datas of
268− Nothing -> throwError ReadThunkError_UnrecognizedThunk
269− Just xs -> fold1WithM xs $ \a b -> either throwError pure (mergeThunkData a b)
270− where
271− rootPathsOnly = Set.fromList . mapMaybe takeRootDir . Map.keys
272− takeRootDir = fmap NonEmpty.head . nonEmpty . splitPath
273−
274− expectedPaths = rootPathsOnly $ _thunkSpec_files thunkSpec
275−
276− requiredPaths = rootPathsOnly $ Map.filter isRequiredFileSpec $ _thunkSpec_files thunkSpec
277− isRequiredFileSpec = \case
278− ThunkFileSpec_FileMatches _ -> True
279− _ -> False
280−
281− dirMayExist expectedPath = liftIO (doesFileExist (dir </> expectedPath)) >>= \case
282− True -> throwError $ ReadThunkError_UnrecognizedPaths $ expectedPath :| []
283− False -> pure ()
284−
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
291−
292− bothPackedAndUnpacked = ReadThunkError_UnrecognizedState "Both packed data and checkout present"
293−
294− fold1WithM (x :| xs) f = foldM f x xs
295−
296−readThunkWith
297− :: (MonadObelisk m)
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}|]
246+gitHubThunkType :: ThunkType
247+gitHubThunkType = ThunkType
248+ { _thunkType_loader = "default.nix"
249+ , _thunkType_json = "github.json"
250+ , _thunkType_optional = Set.fromList [attrCacheFileName]
251+ , _thunkType_loaderVersions = gitHubStandaloneLoaders
252+ , _thunkType_parser = parseThunkPtr $ \v ->
253+ ThunkSource_GitHub <$> parseGitHubSource v <|> ThunkSource_Git <$> parseGitSource v
254+ }
255+
256+gitThunkType :: ThunkType
257+gitThunkType = ThunkType
258+ { _thunkType_loader = "default.nix"
259+ , _thunkType_json = "git.json"
260+ , _thunkType_optional = Set.fromList [attrCacheFileName]
261+ , _thunkType_loaderVersions = plainGitStandaloneLoaders
262+ , _thunkType_parser = parseThunkPtr $ fmap ThunkSource_Git . parseGitSource
263+ }
264+
265+thunkTypes :: [ThunkType]
266+thunkTypes = [gitThunkType, gitHubThunkType]
267+
268+findThunkType :: [ThunkType] -> FilePath -> IO (Either ReadThunkError ThunkType)
269+findThunkType types thunkDir = do
270+ matches <- fmap catMaybes $ forM types $ \thunkType -> do
271+ let
272+ expectedContents = Set.fromList $ (thunkDir </>) <$>
273+ [ _thunkType_loader thunkType
274+ , _thunkType_json thunkType
275+ ]
276+ optionalContents = Set.map (thunkDir </>) (_thunkType_optional thunkType)
277+
278+ -- Ensure that there aren't any other files in the thunk
279+ -- NB: System.Directory.listDirectory returns the contents without the directory path
280+ files <- liftIO $ Set.fromList . fmap (thunkDir </>) <$> listDirectory thunkDir
281+ let unexpectedContents = files `Set.difference` (expectedContents `Set.union` optionalContents)
282+ missingContents = expectedContents `Set.difference` files
283+ pure $ if Set.null unexpectedContents && Set.null missingContents
284+ then Just thunkType
285+ else Nothing
286+
287+ pure $ case matches of
288+ [singleMatch] -> Right singleMatch
289+ [] -> Left ReadThunkError_UnrecognizedFiles
290+ _ -> Left ReadThunkError_AmbiguousFiles
307291
308292-- | Read a thunk and validate that it is exactly a packed thunk.
309293-- If additional data is present, fail.
310−readThunk :: (MonadObelisk m) => FilePath -> m (Either ReadThunkError ThunkData)
311−readThunk = readThunkWith thunkSpecTypes
294+readPackedThunk :: FilePath -> IO (Either ReadThunkError ThunkPtr)
295+readPackedThunk thunkDir = runExceptT $ do
296+ thunkType <- ExceptT $ findThunkType thunkTypes thunkDir
297+ -- Ensure that we recognize the thunk loader
298+ loader <- liftIO $ T.readFile $ thunkDir </> _thunkType_loader thunkType
299+ unless (loader `elem` _thunkType_loaderVersions thunkType) $ do
300+ throwError $ ReadThunkError_UnrecognizedLoader loader
301+
302+ txt <- liftIO $ LBS.readFile $ thunkDir </> _thunkType_json thunkType
303+ case parseMaybe (_thunkType_parser thunkType) =<< Aeson.decode txt of
304+ Nothing -> throwError $ ReadThunkError_UnparseablePtr txt
305+ Just ptr -> return ptr
312306
313307parseThunkPtr :: (Aeson.Object -> Aeson.Parser ThunkSource) -> Aeson.Object -> Aeson.Parser ThunkPtr
314308parseThunkPtr parseSrc v = do
@@ -352,18 +346,16 @@ parseGitSource v = do
352346overwriteThunk :: MonadObelisk m => FilePath -> ThunkPtr -> m ()
353347overwriteThunk target thunk = do
354348 -- Ensure that this directory is a valid thunk (i.e. so we aren't losing any data)
355− readThunk target >>= \case
356− Left e -> failWith [i|Invalid thunk at ${target}: ${e}|]
357− Right _ -> pure ()
349+ Right _ <- readThunk target
358350
359351 --TODO: Is there a safer way to do this overwriting?
360− liftIO $ removePathForcibly target
361− createThunk target $ Right thunk
352+ liftIO $ removeDirectoryRecursive target
353+ liftIO $ createThunk target thunk
362354
363−thunkPtrToSpec :: ThunkPtr -> ThunkSpec
364−thunkPtrToSpec thunk = case _thunkPtr_source thunk of
365− ThunkSource_GitHub _ -> NonEmpty.head gitHubThunkSpecs
366− ThunkSource_Git _ -> NonEmpty.head gitThunkSpecs
355+thunkPtrLoader :: ThunkPtr -> Text
356+thunkPtrLoader thunk = case _thunkPtr_source thunk of
357+ ThunkSource_GitHub _ -> NonEmpty.head gitHubStandaloneLoaders
358+ ThunkSource_Git _ -> NonEmpty.head plainGitStandaloneLoaders
367359
368360-- It's important that formatting be very consistent here, because
369361-- otherwise when people update thunks, their patches will be messy
@@ -410,41 +402,35 @@ encodeThunkPtrData (ThunkPtr rev src) = case src of
410402 , confTrailingNewline = True
411403 }
412404
413−createThunk :: MonadObelisk m => FilePath -> Either ThunkSpec ThunkPtr -> m ()
414−createThunk target ptrInfo =
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)
420− _ -> pure ()
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
427− f fullPath
405+createThunk :: MonadIO m => FilePath -> ThunkPtr -> m ()
406+createThunk target thunk = liftIO $ do
407+ createDirectoryIfMissing True (target </> attrCacheFileName)
408+ T.writeFile (target </> "default.nix") (thunkPtrLoader thunk)
409+ let
410+ jsonFileName = case _thunkPtr_source thunk of
411+ ThunkSource_GitHub _ -> "github"
412+ ThunkSource_Git _ -> "git"
413+ LBS.writeFile (target </> jsonFileName <.> "json") (encodeThunkPtrData thunk)
428414
429415createThunkWithLatest :: MonadObelisk m => FilePath -> ThunkSource -> m ()
430416createThunkWithLatest target s = do
431417 rev <- getLatestRev s
432− createThunk target $ Right $ ThunkPtr
418+ createThunk target $ ThunkPtr
433419 { _thunkPtr_source = s
434420 , _thunkPtr_rev = rev
435421 }
436422
437423updateThunkToLatest :: MonadObelisk m => ThunkUpdateConfig -> FilePath -> m ()
438−updateThunkToLatest (ThunkUpdateConfig mBranch thunkConfig) target = spinner $ do
439− checkThunkDirectory target
424+updateThunkToLatest (ThunkUpdateConfig mBranch thunkConfig) target = withSpinner' ("Updating thunk " <> T.pack target <> " to latest") (pure $ const $ "Thunk " <> T.pack target <> " updated to latest") $ do
425+ checkThunkDirectory "ob thunk update directory cannot be '.'" target
440426 -- check to see if thunk should be updated to a specific branch or just update it's current branch
441427 case mBranch of
442428 Nothing -> do
443429 (overwrite, ptr) <- readThunk target >>= \case
444− Left err -> failWith [i|Thunk update: ${err}|]
430+ Left err -> failWith $ T.pack $ "thunk update: " <> show err
445431 Right c -> case c of
446− ThunkData_Packed _ t -> return (target, t)
447− ThunkData_Checkout -> failWith "cannot update an unpacked thunk"
432+ ThunkData_Packed t -> return (target, t)
433+ ThunkData_Checkout _ -> failWith "cannot update an unpacked thunk"
448434 let src = _thunkPtr_source ptr
449435 rev <- getLatestRev src
450436 overwriteThunk overwrite $ modifyThunkPtrByConfig thunkConfig $ ThunkPtr
@@ -452,12 +438,14 @@ updateThunkToLatest (ThunkUpdateConfig mBranch thunkConfig) target = spinner $ d
452438 , _thunkPtr_rev = rev
453439 }
454440 Just branch -> readThunk target >>= \case
455− Left err -> failWith [i|Thunk update: ${err}|]
441+ Left err -> failWith $ T.pack $ "thunk update: " <> show err
456442 Right c -> case c of
457− ThunkData_Packed _ t -> setThunk thunkConfig target (thunkSourceToGitSource $ _thunkPtr_source t) 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.|]
459− where
460− spinner = withSpinner' ("Updating thunk " <> T.pack target <> " to latest") (pure $ const $ "Thunk " <> T.pack target <> " updated to latest")
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
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."
461449
462450setThunk :: MonadObelisk m => ThunkConfig -> FilePath -> GitSource -> String -> m ()
463451setThunk thunkConfig target gs branch = do
@@ -467,21 +455,21 @@ setThunk thunkConfig target gs branch = do
467455
468456-- | All recognized github standalone loaders, ordered from newest to oldest.
469457-- This tool will only ever produce the newest one when it writes a thunk.
470−gitHubThunkSpecs :: NonEmpty ThunkSpec
471−gitHubThunkSpecs =
472− gitHubThunkSpecV5 :|
473− [ gitHubThunkSpecV4
474− , gitHubThunkSpecV3
475− , gitHubThunkSpecV2
476− , gitHubThunkSpecV1
458+gitHubStandaloneLoaders :: NonEmpty Text
459+gitHubStandaloneLoaders =
460+ gitHubStandaloneLoaderV4 :|
461+ [ gitHubStandaloneLoaderV3
462+ , gitHubStandaloneLoaderV2
463+ , gitHubStandaloneLoaderV1
477464 ]
478465
479−gitHubThunkSpecV1 :: ThunkSpec
480−gitHubThunkSpecV1 = legacyGitHubThunkSpec "github-v1"
481− "import ((import <nixpkgs> {}).fetchFromGitHub (builtins.fromJSON (builtins.readFile ./github.json)))"
466+gitHubStandaloneLoaderV1 :: Text
467+gitHubStandaloneLoaderV1 = T.unlines
468+ [ "import ((import <nixpkgs> {}).fetchFromGitHub (builtins.fromJSON (builtins.readFile ./github.json)))"
469+ ]
482470
483−gitHubThunkSpecV2 :: ThunkSpec
484−gitHubThunkSpecV2 = legacyGitHubThunkSpec "github-v2" $ T.unlines
471+gitHubStandaloneLoaderV2 :: Text
472+gitHubStandaloneLoaderV2 = T.unlines
485473 [ "# DO NOT HAND-EDIT THIS FILE" --TODO: Add something about how to get more info on Obelisk, etc.
486474 , "import ((import <nixpkgs> {}).fetchFromGitHub ("
487475 , " let json = builtins.fromJSON (builtins.readFile ./github.json);"
@@ -491,8 +479,8 @@ gitHubThunkSpecV2 = legacyGitHubThunkSpec "github-v2" $ T.unlines
491479 , "))"
492480 ]
493481
494−gitHubThunkSpecV3 :: ThunkSpec
495−gitHubThunkSpecV3 = legacyGitHubThunkSpec "github-v3" $ T.unlines
482+gitHubStandaloneLoaderV3 :: Text
483+gitHubStandaloneLoaderV3 = T.unlines
496484 [ "# DO NOT HAND-EDIT THIS FILE"
497485 , "let"
498486 , " fetch = { private ? false, ... }@args: if private && builtins.hasAttr \"fetchGit\" builtins"
@@ -511,8 +499,8 @@ gitHubThunkSpecV3 = legacyGitHubThunkSpec "github-v3" $ T.unlines
511499 , "in import (fetch (builtins.fromJSON (builtins.readFile ./github.json)))"
512500 ]
513501
514−gitHubThunkSpecV4 :: ThunkSpec
515−gitHubThunkSpecV4 = legacyGitHubThunkSpec "github-v4" $ T.unlines
502+gitHubStandaloneLoaderV4 :: Text
503+gitHubStandaloneLoaderV4 = T.unlines
516504 [ "# DO NOT HAND-EDIT THIS FILE"
517505 , "let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }:"
518506 , " if !fetchSubmodules && !private then builtins.fetchTarball {"
@@ -523,50 +511,24 @@ gitHubThunkSpecV4 = legacyGitHubThunkSpec "github-v4" $ T.unlines
523511 , "in import (fetch (builtins.fromJSON (builtins.readFile ./github.json)))"
524512 ]
525513
526−legacyGitHubThunkSpec :: Text -> Text -> ThunkSpec
527−legacyGitHubThunkSpec name loader = ThunkSpec name $ Map.fromList
528− [ ("default.nix", ThunkFileSpec_FileMatches $ T.strip loader)
529− , ("github.json" , ThunkFileSpec_Ptr parseGitHubJsonBytes)
530− , (attrCacheFileName, ThunkFileSpec_AttrCache)
531− , (".git", ThunkFileSpec_CheckoutIndicator)
514+plainGitStandaloneLoaders :: NonEmpty Text
515+plainGitStandaloneLoaders =
516+ plainGitStandaloneLoaderV4 :|
517+ [ plainGitStandaloneLoaderV1
518+ , plainGitStandaloneLoaderV2
519+ , plainGitStandaloneLoaderV3
532520 ]
533521
534−gitHubThunkSpecV5 :: ThunkSpec
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;
542− };
543− json = builtins.fromJSON (builtins.readFile ./github.json);
544−in fetch json
545−|]
546−
547−parseGitHubJsonBytes :: LBS.ByteString -> Either String ThunkPtr
548−parseGitHubJsonBytes = parseJsonObject $ parseThunkPtr $ \v ->
549− ThunkSource_GitHub <$> parseGitHubSource v <|> ThunkSource_Git <$> parseGitSource v
550−
551−gitThunkSpecs :: NonEmpty ThunkSpec
552−gitThunkSpecs =
553− gitThunkSpecV5 :|
554− [ gitThunkSpecV4
555− , gitThunkSpecV3
556− , gitThunkSpecV2
557− , gitThunkSpecV1
558− ]
559−
560−gitThunkSpecV1 :: ThunkSpec
561−gitThunkSpecV1 = legacyGitThunkSpec "git-v1" $ T.unlines
522+plainGitStandaloneLoaderV1 :: Text
523+plainGitStandaloneLoaderV1 = T.unlines
562524 [ "# DO NOT HAND-EDIT THIS FILE"
563525 , "let fetchGit = {url, rev, ref ? null, branch ? null, sha256 ? null, fetchSubmodules ? null}:"
564526 , " assert !fetchSubmodules; (import <nixpkgs> {}).fetchgit { inherit url rev sha256; };"
565527 , "in import (fetchGit (builtins.fromJSON (builtins.readFile ./git.json)))"
566528 ]
567529
568−gitThunkSpecV2 :: ThunkSpec
569−gitThunkSpecV2 = legacyGitThunkSpec "git-v2" $ T.unlines
530+plainGitStandaloneLoaderV2 :: Text
531+plainGitStandaloneLoaderV2 = T.unlines
570532 [ "# DO NOT HAND-EDIT THIS FILE"
571533 , "let fetchGit = {url, rev, ref ? null, branch ? null, sha256 ? null, fetchSubmodules ? null}:"
572534 , " if builtins.hasAttr \"fetchGit\" builtins"
@@ -577,8 +539,8 @@ gitThunkSpecV2 = legacyGitThunkSpec "git-v2" $ T.unlines
577539
578540-- This loader has a bug because @builtins.fetchGit@ is not given a @ref@
579541-- and will fail to find commits without this because it does shallow clones.
580−gitThunkSpecV3 :: ThunkSpec
581−gitThunkSpecV3 = legacyGitThunkSpec "git-v3" $ T.unlines
542+plainGitStandaloneLoaderV3 :: Text
543+plainGitStandaloneLoaderV3 = T.unlines
582544 [ "# DO NOT HAND-EDIT THIS FILE"
583545 , "let fetch = {url, rev, ref ? null, sha256 ? null, fetchSubmodules ? false, private ? false, ...}:"
584546 , " let realUrl = let firstChar = builtins.substring 0 1 url; in"
@@ -593,8 +555,8 @@ gitThunkSpecV3 = legacyGitThunkSpec "git-v3" $ T.unlines
593555 , "in import (fetch (builtins.fromJSON (builtins.readFile ./git.json)))"
594556 ]
595557
596−gitThunkSpecV4 :: ThunkSpec
597−gitThunkSpecV4 = legacyGitThunkSpec "git-v4" $ T.unlines
558+plainGitStandaloneLoaderV4 :: Text
559+plainGitStandaloneLoaderV4 = T.unlines
598560 [ "# DO NOT HAND-EDIT THIS FILE"
599561 , "let fetch = {url, rev, branch ? null, sha256 ? null, fetchSubmodules ? false, private ? false, ...}:"
600562 , " let realUrl = let firstChar = builtins.substring 0 1 url; in"
@@ -610,52 +572,10 @@ gitThunkSpecV4 = legacyGitThunkSpec "git-v4" $ T.unlines
610572 , "in import (fetch (builtins.fromJSON (builtins.readFile ./git.json)))"
611573 ]
612574
613−legacyGitThunkSpec :: Text -> Text -> ThunkSpec
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)
619− ]
620−
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
628− else 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;
634− };
635− json = builtins.fromJSON (builtins.readFile ./git.json);
636−in fetch json
637−|]
638−
639−parseGitJsonBytes :: LBS.ByteString -> Either String ThunkPtr
640−parseGitJsonBytes = parseJsonObject $ parseThunkPtr $ fmap ThunkSource_Git . parseGitSource
641−
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)
649− ]
650− where
651− defaultNixViaSrc = [here|
652−# DO NOT HAND-EDIT THIS FILE
653−import (import ./thunk.nix)
654−|]
575+thunkFileNames :: [FilePath]
576+thunkFileNames = ["default.nix", "github.json", "git.json"]
655577
656−
657−parseJsonObject :: (Aeson.Object -> Aeson.Parser a) -> LBS.ByteString -> Either String a
658−parseJsonObject p bytes = Aeson.parseEither p =<< Aeson.eitherDecode bytes
578+--TODO: when checking something out, make a shallow clone
659579
660580-- | Checks a cache directory to see if there is a fresh symlink
661581-- to the result of building an attribute of a thunk.
@@ -663,49 +583,44 @@ parseJsonObject p bytes = Aeson.parseEither p =<< Aeson.eitherDecode bytes
663583-- and the result is symlinked into the cache.
664584nixBuildThunkAttrWithCache
665585 :: MonadObelisk m
666− => ThunkSpec
667− -> FilePath
586+ => FilePath
668587 -- ^ Path to directory containing Thunk
669588 -> String
670589 -- ^ Attribute to build
671− -> m (Maybe FilePath)
590+ -> m FilePath
672591 -- ^ Symlink to cached or built nix output
673592-- WARNING: If the thunk uses an impure reference such as '<nixpkgs>'
674593-- the caching mechanism will fail as it merely measures the modification
675594-- 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"
677603 latestChange <- liftIO $ do
678− let
679− getModificationTimeMaybe = fmap rightToMaybe . try @IOError . getModificationTime
680− thunkFileNames = Map.keys $ _thunkSpec_files thunkSpec
681− maximum . catMaybes <$> traverse (getModificationTimeMaybe . (thunkDir </>)) thunkFileNames
682−
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
687− let
688− cachePath = thunkDir </> cacheDir </> attr <.> "out"
689− cacheErrHandler e
690− | isDoesNotExistError e = pure Nothing -- expected from a cache miss
691− | otherwise = Nothing <$ putLog Error (T.pack $ displayException e)
692− cacheHit <- handle cacheErrHandler $ do
693− cacheTime <- liftIO $ posixSecondsToUTCTime . realToFrac . modificationTime <$> getSymbolicLinkStatus cachePath
694− pure $ if latestChange <= cacheTime
695− then Just cachePath
696− else Nothing
697− case cacheHit of
698− Just c -> pure c
699− Nothing -> do
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
708− }
604+ createDirectoryIfMissing False cacheDir
605+ let getModificationTimeMaybe = fmap rightToMaybe . try @IOError . getModificationTime
606+ maximum . catMaybes <$> mapM (getModificationTimeMaybe . (thunkDir </>)) thunkFileNames
607+ cacheHit <- handle cacheErrHandler $ do
608+ cacheTime <- liftIO $ posixSecondsToUTCTime . realToFrac . modificationTime <$> getSymbolicLinkStatus cachePath
609+ return $ if latestChange <= cacheTime
610+ then Just cachePath
611+ else Nothing
612+ case cacheHit of
613+ Just c -> return c
614+ Nothing -> do
615+ putLog Warning $ T.pack $ mconcat [thunkDir, ": ", attr, " not cached, building ..."]
616+ _ <- nixCmd $ NixCmd_Build $ def
617+ Lens.& nixBuildConfig_outLink Lens..~ OutLink_IndirectRoot cachePath
618+ Lens.& nixCmdConfig_target Lens..~ Target
619+ { _target_path = Just thunkDir
620+ , _target_attr = Just attr
621+ , _target_expr = Nothing
622+ }
623+ return cachePath
709624
710625-- | Build a nix attribute, and cache the result if possible
711626nixBuildAttrWithCache
@@ -716,15 +631,13 @@ nixBuildAttrWithCache
716631 -- ^ Attribute to build
717632 -> m FilePath
718633 -- ^ Symlink to cached or built nix output
719−nixBuildAttrWithCache exprPath attr = readThunk exprPath >>= \case
720− -- Only packed thunks are cached. In particular, checkouts are not.
721− Right (ThunkData_Packed spec _) ->
722− maybe build pure =<< nixBuildThunkAttrWithCache spec exprPath attr
723− _ -> build
724− where
725− build = nixCmd $ NixCmd_Build $ def
726− & nixBuildConfig_outLink .~ OutLink_None
727− & nixCmdConfig_target .~ Target
634+nixBuildAttrWithCache exprPath attr = do
635+ readThunk exprPath >>= \case
636+ -- Only packed thunks are cached. in particular, checkouts are not
637+ Right (ThunkData_Packed _) -> nixBuildThunkAttrWithCache exprPath attr
638+ _ -> nixCmd $ NixCmd_Build $ def
639+ Lens.& nixBuildConfig_outLink Lens..~ OutLink_None
640+ Lens.& nixCmdConfig_target Lens..~ Target
728641 { _target_path = Just exprPath
729642 , _target_attr = Just attr
730643 , _target_expr = Nothing
@@ -745,7 +658,7 @@ updateThunk p f = withSystemTempDirectory "obelisk-thunkptr-" $ \tmpDir -> do
745658 where
746659 copyThunkToTmp tmpDir thunkDir = readThunk thunkDir >>= \case
747660 Left err -> failWith $ "withThunkUnpacked: " <> T.pack (show err)
748− Right ThunkData_Packed{} -> do
661+ Right (ThunkData_Packed _) -> do
749662 let tmpThunk = tmpDir </> "thunk"
750663 callProcessAndLogOutput (Notice, Error) $
751664 proc cp ["-r", "-T", thunkDir, tmpThunk]
@@ -759,81 +672,62 @@ updateThunk p f = withSystemTempDirectory "obelisk-thunkptr-" $ \tmpDir -> do
759672finalMsg :: Bool -> (a -> Text) -> Maybe (a -> Text)
760673finalMsg noTrail s = if noTrail then Nothing else Just s
761674
675+unpackThunk :: MonadObelisk m => FilePath -> m ()
676+unpackThunk = unpackThunk' False
677+
762678-- | Check that we are not somewhere inside the thunk directory
763−checkThunkDirectory :: MonadObelisk m => FilePath -> m ()
764−checkThunkDirectory thunkDir = do
679+checkThunkDirectory :: MonadObelisk m => Text -> FilePath -> m ()
680+checkThunkDirectory msg thunkDir = do
765681 currentDir <- liftIO getCurrentDirectory
766682 thunkDir' <- liftIO $ canonicalizePath thunkDir
767− when (thunkDir' `L.isInfixOf` currentDir) $
768− failWith [i|Can't perform thunk operations from within the thunk directory: ${thunkDir}|]
769−
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|]
774− Left _ -> pure ()
775−
776−unpackThunk :: MonadObelisk m => FilePath -> m ()
777−unpackThunk = unpackThunk' False
683+ when (thunkDir' `L.isInfixOf` currentDir) $ failWith msg
778684
779685unpackThunk' :: MonadObelisk m => Bool -> FilePath -> m ()
780−unpackThunk' noTrail thunkDir = checkThunkDirectory thunkDir *> readThunk thunkDir >>= \case
781− Left err -> failWith [i|Invalid thunk at ${thunkDir}: ${err}|]
686+unpackThunk' noTrail thunkDir = checkThunkDirectory "Can't pack/unpack from within the thunk directory" thunkDir >> readThunk thunkDir >>= \case
687+ Left err -> failWith $ "thunk unpack: " <> T.pack (show err)
782688 --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|]
784− Right (ThunkData_Packed _ tptr) -> do
689+ Right (ThunkData_Checkout _) -> failWith "thunk unpack: thunk is already unpacked"
690+ Right (ThunkData_Packed tptr) -> do
785691 let (thunkParent, thunkName) = splitFileName thunkDir
786− withTempDirectory thunkParent thunkName $ \tmpThunk -> do
787− let
788− gitSrc = thunkSourceToGitSource $ _thunkPtr_source tptr
789− newSpec = case _thunkPtr_source tptr of
790− ThunkSource_GitHub _ -> NonEmpty.head gitHubThunkSpecs
791− ThunkSource_Git _ -> NonEmpty.head gitThunkSpecs
692+ withTempDirectory thunkParent thunkName $ \tmpRepo -> do
693+ let obGitDir = tmpRepo </> ".git" </> "obelisk"
694+ s = case _thunkPtr_source tptr of
695+ ThunkSource_GitHub s' -> forgetGithub False s'
696+ ThunkSource_Git s' -> s'
792697 withSpinner' ("Fetching thunk " <> T.pack thunkName)
793698 (finalMsg noTrail $ const $ "Fetched thunk " <> T.pack thunkName) $ do
794− let unpackedPath = tmpThunk </> unpackedDirName
795− gitCloneForThunkUnpack gitSrc (_thunkRev_commit $ _thunkPtr_rev tptr) unpackedPath
796−
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
800−
801− liftIO $ do
802− removePathForcibly thunkDir
803− renameDirectory tmpThunk thunkDir
804−
805−gitCloneForThunkUnpack
806− :: MonadObelisk m
807− => GitSource -- ^ Git source to use
808− -> Ref hash -- ^ Commit hash to reset to
809− -> FilePath -- ^ Directory to clone into
810− -> m ()
811−gitCloneForThunkUnpack gitSrc commit dir = do
812− let git = callProcessAndLogOutput (Notice, Notice) . gitProc dir
813− git $ [ "clone" ]
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"]
699+ let git = callProcessAndLogOutput (Notice, Notice) . gitProc tmpRepo
700+ git $ [ "clone" ]
701+ ++ ("--recursive" <$ guard (_gitSource_fetchSubmodules s))
702+ ++ [ T.unpack $ gitUriToText $ _gitSource_url s ]
703+ ++ do branch <- maybeToList $ _gitSource_branch s
704+ [ "--branch", T.unpack $ untagName branch ]
705+ git ["reset", "--hard", Ref.toHexString $ _thunkRev_commit $ _thunkPtr_rev tptr]
706+ when (_gitSource_fetchSubmodules s) $
707+ git ["submodule", "update", "--recursive", "--init"]
708+
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]
821716
822717--TODO: add a rollback mode to pack to the original thunk
823718packThunk :: MonadObelisk m => ThunkPackConfig -> FilePath -> m ThunkPtr
824719packThunk = packThunk' False
825720
826721packThunk' :: MonadObelisk m => Bool -> ThunkPackConfig -> FilePath -> m ThunkPtr
827−packThunk' noTrail (ThunkPackConfig force thunkConfig) thunkDir = checkThunkDirectory thunkDir *> readThunk thunkDir >>= \case
828− Right ThunkData_Packed{} -> failWith [i|Thunk at ${thunkDir} is is already packed|]
829− _ -> withSpinner'
830− ("Packing thunk " <> T.pack thunkDir)
831− (finalMsg noTrail $ const $ "Packed thunk " <> T.pack thunkDir) $
832− do
833− let checkClean = if force then CheckClean_NoCheck else CheckClean_FullCheck
834− thunkPtr <- modifyThunkPtrByConfig thunkConfig <$> getThunkPtr checkClean thunkDir (_thunkConfig_private thunkConfig)
835− liftIO $ removePathForcibly thunkDir
836− createThunk thunkDir $ Right thunkPtr
722+packThunk' noTrail (ThunkPackConfig force thunkConfig) thunkDir = checkThunkDirectory "Can't pack/unpack from within the thunk directory" thunkDir >> readThunk thunkDir >>= \case
723+ Left err -> failWith $ T.pack $ "thunk pack: " <> show err
724+ Right (ThunkData_Packed _) -> failWith "pack: thunk is already packed"
725+ Right (ThunkData_Checkout _) -> do
726+ withSpinner' ("Packing thunk " <> T.pack thunkDir)
727+ (finalMsg noTrail $ const $ "Packed thunk " <> T.pack thunkDir) $ do
728+ thunkPtr <- modifyThunkPtrByConfig thunkConfig <$> getThunkPtr (not force) thunkDir (_thunkConfig_private thunkConfig)
729+ callProcessAndLogOutput (Debug, Error) $ proc "rm" ["-rf", thunkDir]
730+ liftIO $ createThunk thunkDir thunkPtr
837731 pure thunkPtr
838732
839733modifyThunkPtrByConfig :: ThunkConfig -> ThunkPtr -> ThunkPtr
@@ -844,43 +738,29 @@ modifyThunkPtrByConfig (ThunkConfig markPrivate') ptr = case markPrivate' of
844738 ThunkSource_GitHub s -> ThunkSource_GitHub $ s { _gitHubSource_private = markPrivate }
845739 }
846740
847−data CheckClean
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
854−
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
863−
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
741+getThunkPtr :: forall m. MonadObelisk m => Bool -> FilePath -> Maybe Bool -> m ThunkPtr
742+getThunkPtr checkClean thunkDir mPrivate = do
743+ when checkClean $ ensureCleanGitRepo thunkDir True
869744 "thunk pack: thunk checkout contains unsaved modifications"
870745
871746 -- Check whether there are any stashes
872− when checkClean $ do
873− stashOutput <- readGitProcess thunkDir ["stash", "list"]
874− unless (T.null stashOutput) $
747+ stashOutput <- readGitProcess thunkDir ["stash", "list"]
748+ when checkClean $ case T.null stashOutput of
749+ False -> do
875750 failWith $ T.unlines $
876751 [ "thunk pack: thunk checkout has stashes"
877752 , "git stash list:"
878753 ] ++ T.lines stashOutput
754+ True -> return ()
879755
880756 -- Get current branch
881757 (mCurrentBranch, mCurrentCommit) <- do
882− b <- listToMaybe . T.lines <$> readGitProcess thunkDir ["rev-parse", "--abbrev-ref", "HEAD"]
883− c <- listToMaybe . T.lines <$> readGitProcess thunkDir ["rev-parse", "HEAD"]
758+ b <- listToMaybe
759+ <$> T.lines
760+ <$> readGitProcess thunkDir ["rev-parse", "--abbrev-ref", "HEAD"]
761+ c <- listToMaybe
762+ <$> T.lines
763+ <$> readGitProcess thunkDir ["rev-parse", "HEAD"]
884764 case b of
885765 (Just "HEAD") -> failWith $ T.unlines
886766 [ "thunk pack: You are in 'detached HEAD' state."
@@ -891,7 +771,7 @@ getThunkPtr gitCheckClean dir mPrivate = do
891771
892772 -- Get information on all branches and their (optional) designated upstream
893773 -- correspondents
894− headDump :: [Text] <- T.lines <$> readGitProcess thunkDir
774+ (headDump :: [Text]) <- T.lines <$> readGitProcess thunkDir
895775 [ "for-each-ref"
896776 , "--format=%(refname:short) %(upstream:short) %(upstream:remotename)"
897777 , "refs/heads/"
@@ -937,7 +817,7 @@ getThunkPtr gitCheckClean dir mPrivate = do
937817 ]
938818
939819 -- 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
941821 (stat :: [Text]) <- T.lines <$> readGitProcess thunkDir
942822 [ "rev-list", "--left-right"
943823 , T.unpack branch <> "..." <> T.unpack upstream
@@ -961,9 +841,8 @@ getThunkPtr gitCheckClean dir mPrivate = do
961841 \pushed but this repo's remote tracking branches don't know it.)"
962842 ]
963843
964− when checkClean $ do
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."
844+ -- We assume it's safe to pack the thunk at this point
845+ putLog Informational "All changes safe in git remotes. OK to pack thunk."
967846
968847 let remote = maybe "origin" snd $ flip Map.lookup headUpstream =<< mCurrentBranch
969848
@@ -981,7 +860,9 @@ getThunkPtr gitCheckClean dir mPrivate = do
981860-- | Get the latest revision available from the given source
982861getLatestRev :: MonadObelisk m => ThunkSource -> m ThunkRev
983862getLatestRev 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
985866 (_, commit) <- gitGetCommitBranch (_gitSource_url gitS) (untagName <$> _gitSource_branch gitS)
986867 case os of
987868 ThunkSource_GitHub s -> githubThunkRev s commit