@@ -5,65 +5,48 @@
55{-# LANGUAGE MultiWayIf #-}
66{-# LANGUAGE OverloadedStrings #-}
77{-# LANGUAGE PatternGuards #-}
8+{-# LANGUAGE QuasiQuotes #-}
89{-# LANGUAGE ScopedTypeVariables #-}
910{-# LANGUAGE TypeApplications #-}
10−module Obelisk.Command.Thunk
11− ( GitHubSource (..)
12− , GitUri (..)
13− , ReadThunkError (..)
14− , ThunkConfig (..)
15− , ThunkData (..)
16− , ThunkPackConfig (..)
17− , ThunkPtr (..)
18− , ThunkRev (..)
19− , ThunkSource (..)
20− , ThunkUpdateConfig (..)
21− , createThunk
22− , createThunkWithLatest
23− , getLatestRev
24− , getThunkGitBranch
25− , getThunkPtr
26− , gitUriToText
27− , nixBuildAttrWithCache
28− , nixBuildThunkAttrWithCache
29− , packThunk
30− , parseGitUri
31− , readThunk
32− , unpackThunk
33− , updateThunk
34− , updateThunkToLatest
35− , uriThunkPtr
36− ) where
11+module Obelisk.Command.Thunk where
3712
3813import Control.Applicative
3914import Control.Exception (displayException, try)
40−import qualified Control.Lens as Lens
41−import Control.Lens.Indexed hiding ((<.>))
15+import Control.Lens (ifor, ifor_, (.~))
4216import Control.Monad
43−import Control.Monad.Catch (handle)
17+import Control.Monad.Extra (findM)
18+import Control.Monad.Catch (MonadCatch, handle)
4419import Control.Monad.Except
4520import Data.Aeson ((.=))
4621import qualified Data.Aeson as Aeson
4722import Data.Aeson.Encode.Pretty
4823import qualified Data.Aeson.Types as Aeson
24+import Data.Bifunctor (first)
4925import qualified Data.ByteString.Lazy as LBS
26+import Data.Containers.ListUtils (nubOrd)
5027import Data.Default
5128import Data.Either.Combinators (fromRight', rightToMaybe)
29+import Data.Foldable (toList)
30+import Data.Function ((&))
31+import Data.Functor ((<&>))
5232import Data.Git.Ref (Ref)
5333import qualified Data.Git.Ref as Ref
5434import qualified Data.List as L
55−import Data.List.NonEmpty (NonEmpty (..))
35+import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
5636import qualified Data.List.NonEmpty as NonEmpty
5737import Data.Map (Map)
5838import qualified Data.Map as Map
5939import Data.Maybe
6040import Data.Set (Set)
6141import qualified Data.Set as Set
42+import Data.String.Here.Interpolated (i)
43+import Data.String.Here.Uninterpolated (here)
6244import Data.Text (Text)
6345import qualified Data.Text as T
6446import Data.Text.Encoding
6547import qualified Data.Text.IO as T
6648import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
49+import Data.Traversable (for)
6750import Data.Yaml (parseMaybe)
6851import GitHub
6952import GitHub.Data.Name
@@ -73,7 +56,7 @@ import System.Exit
7356import System.FilePath
7457import System.IO.Error
7558import System.IO.Temp
76−import System.Posix (getSymbolicLinkStatus, modificationTime)
59+import System.PosixCompat.Files (getSymbolicLinkStatus, modificationTime)
7760import qualified Text.URI as URI
7861
7962import Obelisk.App (MonadObelisk)
@@ -82,11 +65,10 @@ import Obelisk.Command.Utils
8265
8366--TODO: Support symlinked thunk data
8467data ThunkData
85− = ThunkData_Packed ThunkPtr
68+ = ThunkData_Packed ThunkSpec ThunkPtr
8669 -- ^ Packed thunk
87− | ThunkData_Checkout (Maybe ThunkPtr)
70+ | ThunkData_Checkout
8871 -- ^ Checked out thunk that was unpacked from this pointer
89− deriving (Show, Eq, Ord)
9072
9173-- | A reference to the exact data that a thunk should translate into
9274data ThunkPtr = ThunkPtr
@@ -112,6 +94,11 @@ data ThunkSource
11294 | ThunkSource_Git GitSource
11395 deriving (Show, Eq, Ord)
11496
97+thunkSourceToGitSource :: ThunkSource -> GitSource
98+thunkSourceToGitSource = \case
99+ ThunkSource_GitHub s -> forgetGithub False s
100+ ThunkSource_Git s -> s
101+
115102data GitHubSource = GitHubSource
116103 { _gitHubSource_owner :: Name Owner
117104 , _gitHubSource_repo :: Name Repo
@@ -120,7 +107,7 @@ data GitHubSource = GitHubSource
120107 }
121108 deriving (Show, Eq, Ord)
122109
123−newtype GitUri = GitUri URI.URI deriving (Eq, Ord, Show)
110+newtype GitUri = GitUri { unGitUri :: URI.URI } deriving (Eq, Ord, Show)
124111
125112gitUriToText :: GitUri -> Text
126113gitUriToText (GitUri uri)
@@ -191,14 +178,14 @@ getNixSha256ForUriUnpacked
191178getNixSha256ForUriUnpacked uri =
192179 withExitFailMessage ("nix-prefetch-url: Failed to determine sha256 hash of URL " <> gitUriToText uri) $ do
193180 [hash] <- fmap T.lines $ readProcessAndLogOutput (Debug, Debug) $
194− proc "nix-prefetch-url" ["--unpack", "--type", "sha256", T.unpack $ gitUriToText uri]
181+ proc nixPrefetchUrlPath ["--unpack", "--type", "sha256", T.unpack $ gitUriToText uri]
195182 pure hash
196183
197184nixPrefetchGit :: MonadObelisk m => GitUri -> Text -> Bool -> m NixSha256
198185nixPrefetchGit uri rev fetchSubmodules =
199186 withExitFailMessage ("nix-prefetch-git: Failed to determine sha256 hash of Git repo " <> gitUriToText uri <> " at " <> rev) $ do
200187 out <- readProcessAndLogStderr Debug $
201− proc "nix-prefetch-git" $ filter (/="")
188+ proc nixPrefetchGitPath $ filter (/="")
202189 [ "--url", T.unpack $ gitUriToText uri
203190 , "--rev", T.unpack rev
204191 , if fetchSubmodules then "--fetch-submodules" else ""
@@ -211,93 +198,117 @@ nixPrefetchGit uri rev fetchSubmodules =
211198
212199--TODO: Pretty print these
213200data ReadThunkError
214− = ReadThunkError_UnrecognizedFiles
215− | ReadThunkError_AmbiguousFiles
216− | ReadThunkError_UnrecognizedLoader Text
217− | ReadThunkError_UnparseablePtr LBS.ByteString
218− deriving (Show)
219−
220−-- | Read a thunk and validate that it is only a thunk, either packed or unpacked.
221−-- If the thunk is packed and additional data is present, fail.
222−readThunk :: MonadObelisk m => FilePath -> m (Either ReadThunkError ThunkData)
223−readThunk thunkDir = do
224− files <- liftIO $ listDirectory thunkDir
225− case ".git" `elem` files of
226− True -> fmap ThunkData_Checkout <$> do
227− let origThunkPath = thunkDir </> ".git" </> "obelisk" </> "orig-thunk"
228− liftIO $ doesDirectoryExist origThunkPath >>= \case
229− True -> fmap Just <$> readPackedThunk origThunkPath
230− False -> return $ return Nothing
231− False -> liftIO $ fmap ThunkData_Packed <$> readPackedThunk thunkDir
232−
233−data ThunkType = ThunkType
234− { _thunkType_loader :: FilePath
235− , _thunkType_json :: FilePath
236− , _thunkType_optional :: Set FilePath
237− , _thunkType_loaderVersions :: NonEmpty Text
238− , _thunkType_parser :: Aeson.Object -> Aeson.Parser ThunkPtr
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 = "."
213+
214+attrCacheFileName :: FilePath
215+attrCacheFileName = ".attr-cache"
216+
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)
239228 }
240229
241−gitHubThunkType :: ThunkType
242−gitHubThunkType = ThunkType
243− { _thunkType_loader = "default.nix"
244− , _thunkType_json = "github.json"
245− , _thunkType_optional = Set.fromList [".attr-cache"]
246− , _thunkType_loaderVersions = gitHubStandaloneLoaders
247− , _thunkType_parser = parseThunkPtr $ \v ->
248− ThunkSource_GitHub <$> parseGitHubSource v <|> ThunkSource_Git <$> parseGitSource v
249− }
250−
251−gitThunkType :: ThunkType
252−gitThunkType = ThunkType
253− { _thunkType_loader = "default.nix"
254− , _thunkType_json = "git.json"
255− , _thunkType_optional = Set.fromList [".attr-cache"]
256− , _thunkType_loaderVersions = plainGitStandaloneLoaders
257− , _thunkType_parser = parseThunkPtr $ fmap ThunkSource_Git . parseGitSource
258− }
259−
260−thunkTypes :: [ThunkType]
261−thunkTypes = [gitThunkType, gitHubThunkType]
262−
263−findThunkType :: [ThunkType] -> FilePath -> IO (Either ReadThunkError ThunkType)
264−findThunkType types thunkDir = do
265− matches <- fmap catMaybes $ forM types $ \thunkType -> do
266− let
267− expectedContents = Set.fromList $ (thunkDir </>) <$>
268− [ _thunkType_loader thunkType
269− , _thunkType_json thunkType
270− ]
271− optionalContents = Set.map (thunkDir </>) (_thunkType_optional thunkType)
272−
273− -- Ensure that there aren't any other files in the thunk
274− -- NB: System.Directory.listDirectory returns the contents without the directory path
275− files <- liftIO $ Set.fromList . fmap (thunkDir </>) <$> listDirectory thunkDir
276− let unexpectedContents = files `Set.difference` (expectedContents `Set.union` optionalContents)
277− missingContents = expectedContents `Set.difference` files
278− pure $ if Set.null unexpectedContents && Set.null missingContents
279− then Just thunkType
280− else Nothing
281−
282− pure $ case matches of
283− [singleMatch] -> Right singleMatch
284− [] -> Left ReadThunkError_UnrecognizedFiles
285− _ -> Left ReadThunkError_AmbiguousFiles
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}|]
286307
287308-- | Read a thunk and validate that it is exactly a packed thunk.
288309-- If additional data is present, fail.
289−readPackedThunk :: FilePath -> IO (Either ReadThunkError ThunkPtr)
290−readPackedThunk thunkDir = runExceptT $ do
291− thunkType <- ExceptT $ findThunkType thunkTypes thunkDir
292− -- Ensure that we recognize the thunk loader
293− loader <- liftIO $ T.readFile $ thunkDir </> _thunkType_loader thunkType
294− unless (loader `elem` _thunkType_loaderVersions thunkType) $ do
295− throwError $ ReadThunkError_UnrecognizedLoader loader
296−
297− txt <- liftIO $ LBS.readFile $ thunkDir </> _thunkType_json thunkType
298− case parseMaybe (_thunkType_parser thunkType) =<< Aeson.decode txt of
299− Nothing -> throwError $ ReadThunkError_UnparseablePtr txt
300− Just ptr -> return ptr
310+readThunk :: (MonadObelisk m) => FilePath -> m (Either ReadThunkError ThunkData)
311+readThunk = readThunkWith thunkSpecTypes
301312
302313parseThunkPtr :: (Aeson.Object -> Aeson.Parser ThunkSource) -> Aeson.Object -> Aeson.Parser ThunkPtr
303314parseThunkPtr parseSrc v = do
@@ -341,16 +352,18 @@ parseGitSource v = do
341352overwriteThunk :: MonadObelisk m => FilePath -> ThunkPtr -> m ()
342353overwriteThunk target thunk = do
343354 -- Ensure that this directory is a valid thunk (i.e. so we aren't losing any data)
344− Right _ <- readThunk target
355+ readThunk target >>= \case
356+ Left e -> failWith [i|Invalid thunk at ${target}: ${e}|]
357+ Right _ -> pure ()
345358
346359 --TODO: Is there a safer way to do this overwriting?
347− liftIO $ removeDirectoryRecursive target
348− liftIO $ createThunk target thunk
360+ liftIO $ removePathForcibly target
361+ createThunk target $ Right thunk
349362
350−thunkPtrLoader :: ThunkPtr -> Text
351−thunkPtrLoader thunk = case _thunkPtr_source thunk of
352− ThunkSource_GitHub _ -> NonEmpty.head gitHubStandaloneLoaders
353− ThunkSource_Git _ -> NonEmpty.head plainGitStandaloneLoaders
363+thunkPtrToSpec :: ThunkPtr -> ThunkSpec
364+thunkPtrToSpec thunk = case _thunkPtr_source thunk of
365+ ThunkSource_GitHub _ -> NonEmpty.head gitHubThunkSpecs
366+ ThunkSource_Git _ -> NonEmpty.head gitThunkSpecs
354367
355368-- It's important that formatting be very consistent here, because
356369-- otherwise when people update thunks, their patches will be messy
@@ -397,35 +410,41 @@ encodeThunkPtrData (ThunkPtr rev src) = case src of
397410 , confTrailingNewline = True
398411 }
399412
400−createThunk :: MonadIO m => FilePath -> ThunkPtr -> m ()
401−createThunk target thunk = liftIO $ do
402− createDirectoryIfMissing True (target </> ".attr-cache")
403− T.writeFile (target </> "default.nix") (thunkPtrLoader thunk)
404− let
405− jsonFileName = case _thunkPtr_source thunk of
406− ThunkSource_GitHub _ -> "github"
407− ThunkSource_Git _ -> "git"
408− LBS.writeFile (target </> jsonFileName <.> "json") (encodeThunkPtrData thunk)
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
409428
410429createThunkWithLatest :: MonadObelisk m => FilePath -> ThunkSource -> m ()
411430createThunkWithLatest target s = do
412431 rev <- getLatestRev s
413− createThunk target $ ThunkPtr
432+ createThunk target $ Right $ ThunkPtr
414433 { _thunkPtr_source = s
415434 , _thunkPtr_rev = rev
416435 }
417436
418437updateThunkToLatest :: MonadObelisk m => ThunkUpdateConfig -> FilePath -> m ()
419−updateThunkToLatest (ThunkUpdateConfig mBranch thunkConfig) target = withSpinner' ("Updating thunk " <> T.pack target <> " to latest") (pure $ const $ "Thunk " <> T.pack target <> " updated to latest") $ do
420− checkThunkDirectory "ob thunk update directory cannot be '.'" target
438+updateThunkToLatest (ThunkUpdateConfig mBranch thunkConfig) target = spinner $ do
439+ checkThunkDirectory target
421440 -- check to see if thunk should be updated to a specific branch or just update it's current branch
422441 case mBranch of
423442 Nothing -> do
424443 (overwrite, ptr) <- readThunk target >>= \case
425− Left err -> failWith $ T.pack $ "thunk update: " <> show err
444+ Left err -> failWith [i|Thunk update: ${err}|]
426445 Right c -> case c of
427− ThunkData_Packed t -> return (target, t)
428− ThunkData_Checkout _ -> failWith "cannot update an unpacked thunk"
446+ ThunkData_Packed _ t -> return (target, t)
447+ ThunkData_Checkout -> failWith "cannot update an unpacked thunk"
429448 let src = _thunkPtr_source ptr
430449 rev <- getLatestRev src
431450 overwriteThunk overwrite $ modifyThunkPtrByConfig thunkConfig $ ThunkPtr
@@ -433,38 +452,36 @@ updateThunkToLatest (ThunkUpdateConfig mBranch thunkConfig) target = withSpinner
433452 , _thunkPtr_rev = rev
434453 }
435454 Just branch -> readThunk target >>= \case
436− Left err -> failWith $ T.pack $ "thunk update: " <> show err
455+ Left err -> failWith [i|Thunk update: ${err}|]
437456 Right c -> case c of
438− ThunkData_Packed t -> case _thunkPtr_source t of
439− ThunkSource_Git tsg -> setThunk thunkConfig target tsg branch
440− ThunkSource_GitHub tsgh -> do
441− let tsg = forgetGithub False tsgh
442− setThunk thunkConfig target tsg branch
443− 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."
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")
444461
445462setThunk :: MonadObelisk m => ThunkConfig -> FilePath -> GitSource -> String -> m ()
446463setThunk thunkConfig target gs branch = do
447− newThunkPtr <- uriThunkPtr (_gitSource_url gs) (Just $ T.pack branch) Nothing
464+ newThunkPtr <- uriThunkPtr (_gitSource_url gs) (_thunkConfig_private thunkConfig) (Just $ T.pack branch) Nothing
448465 overwriteThunk target newThunkPtr
449466 updateThunkToLatest (ThunkUpdateConfig Nothing thunkConfig) target
450467
451468-- | All recognized github standalone loaders, ordered from newest to oldest.
452469-- This tool will only ever produce the newest one when it writes a thunk.
453−gitHubStandaloneLoaders :: NonEmpty Text
454−gitHubStandaloneLoaders =
455− gitHubStandaloneLoaderV4 :|
456− [ gitHubStandaloneLoaderV3
457− , gitHubStandaloneLoaderV2
458− , gitHubStandaloneLoaderV1
470+gitHubThunkSpecs :: NonEmpty ThunkSpec
471+gitHubThunkSpecs =
472+ gitHubThunkSpecV5 :|
473+ [ gitHubThunkSpecV4
474+ , gitHubThunkSpecV3
475+ , gitHubThunkSpecV2
476+ , gitHubThunkSpecV1
459477 ]
460478
461−gitHubStandaloneLoaderV1 :: Text
462−gitHubStandaloneLoaderV1 = T.unlines
463− [ "import ((import <nixpkgs> {}).fetchFromGitHub (builtins.fromJSON (builtins.readFile ./github.json)))"
464− ]
479+gitHubThunkSpecV1 :: ThunkSpec
480+gitHubThunkSpecV1 = legacyGitHubThunkSpec "github-v1"
481+ "import ((import <nixpkgs> {}).fetchFromGitHub (builtins.fromJSON (builtins.readFile ./github.json)))"
465482
466−gitHubStandaloneLoaderV2 :: Text
467−gitHubStandaloneLoaderV2 = T.unlines
483+gitHubThunkSpecV2 :: ThunkSpec
484+gitHubThunkSpecV2 = legacyGitHubThunkSpec "github-v2" $ T.unlines
468485 [ "# DO NOT HAND-EDIT THIS FILE" --TODO: Add something about how to get more info on Obelisk, etc.
469486 , "import ((import <nixpkgs> {}).fetchFromGitHub ("
470487 , " let json = builtins.fromJSON (builtins.readFile ./github.json);"
@@ -474,8 +491,8 @@ gitHubStandaloneLoaderV2 = T.unlines
474491 , "))"
475492 ]
476493
477−gitHubStandaloneLoaderV3 :: Text
478−gitHubStandaloneLoaderV3 = T.unlines
494+gitHubThunkSpecV3 :: ThunkSpec
495+gitHubThunkSpecV3 = legacyGitHubThunkSpec "github-v3" $ T.unlines
479496 [ "# DO NOT HAND-EDIT THIS FILE"
480497 , "let"
481498 , " fetch = { private ? false, ... }@args: if private && builtins.hasAttr \"fetchGit\" builtins"
@@ -494,8 +511,8 @@ gitHubStandaloneLoaderV3 = T.unlines
494511 , "in import (fetch (builtins.fromJSON (builtins.readFile ./github.json)))"
495512 ]
496513
497−gitHubStandaloneLoaderV4 :: Text
498−gitHubStandaloneLoaderV4 = T.unlines
514+gitHubThunkSpecV4 :: ThunkSpec
515+gitHubThunkSpecV4 = legacyGitHubThunkSpec "github-v4" $ T.unlines
499516 [ "# DO NOT HAND-EDIT THIS FILE"
500517 , "let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }:"
501518 , " if !fetchSubmodules && !private then builtins.fetchTarball {"
@@ -506,23 +523,50 @@ gitHubStandaloneLoaderV4 = T.unlines
506523 , "in import (fetch (builtins.fromJSON (builtins.readFile ./github.json)))"
507524 ]
508525
509−plainGitStandaloneLoaders :: NonEmpty Text
510−plainGitStandaloneLoaders =
511− plainGitStandaloneLoaderV3 :|
512− [ plainGitStandaloneLoaderV1
513− , plainGitStandaloneLoaderV2
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)
532+ ]
533+
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
514558 ]
515559
516−plainGitStandaloneLoaderV1 :: Text
517−plainGitStandaloneLoaderV1 = T.unlines
560+gitThunkSpecV1 :: ThunkSpec
561+gitThunkSpecV1 = legacyGitThunkSpec "git-v1" $ T.unlines
518562 [ "# DO NOT HAND-EDIT THIS FILE"
519563 , "let fetchGit = {url, rev, ref ? null, branch ? null, sha256 ? null, fetchSubmodules ? null}:"
520564 , " assert !fetchSubmodules; (import <nixpkgs> {}).fetchgit { inherit url rev sha256; };"
521565 , "in import (fetchGit (builtins.fromJSON (builtins.readFile ./git.json)))"
522566 ]
523567
524−plainGitStandaloneLoaderV2 :: Text
525−plainGitStandaloneLoaderV2 = T.unlines
568+gitThunkSpecV2 :: ThunkSpec
569+gitThunkSpecV2 = legacyGitThunkSpec "git-v2" $ T.unlines
526570 [ "# DO NOT HAND-EDIT THIS FILE"
527571 , "let fetchGit = {url, rev, ref ? null, branch ? null, sha256 ? null, fetchSubmodules ? null}:"
528572 , " if builtins.hasAttr \"fetchGit\" builtins"
@@ -531,8 +575,10 @@ plainGitStandaloneLoaderV2 = T.unlines
531575 , "in import (fetchGit (builtins.fromJSON (builtins.readFile ./git.json)))"
532576 ]
533577
534−plainGitStandaloneLoaderV3 :: Text
535−plainGitStandaloneLoaderV3 = T.unlines
578+-- 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.
580+gitThunkSpecV3 :: ThunkSpec
581+gitThunkSpecV3 = legacyGitThunkSpec "git-v3" $ T.unlines
536582 [ "# DO NOT HAND-EDIT THIS FILE"
537583 , "let fetch = {url, rev, ref ? null, sha256 ? null, fetchSubmodules ? false, private ? false, ...}:"
538584 , " let realUrl = let firstChar = builtins.substring 0 1 url; in"
@@ -547,10 +593,69 @@ plainGitStandaloneLoaderV3 = T.unlines
547593 , "in import (fetch (builtins.fromJSON (builtins.readFile ./git.json)))"
548594 ]
549595
550−thunkFileNames :: [FilePath]
551−thunkFileNames = ["default.nix", "github.json", "git.json"]
596+gitThunkSpecV4 :: ThunkSpec
597+gitThunkSpecV4 = legacyGitThunkSpec "git-v4" $ T.unlines
598+ [ "# DO NOT HAND-EDIT THIS FILE"
599+ , "let fetch = {url, rev, branch ? null, sha256 ? null, fetchSubmodules ? false, private ? false, ...}:"
600+ , " let realUrl = let firstChar = builtins.substring 0 1 url; in"
601+ , " if firstChar == \"/\" then /. + url"
602+ , " else if firstChar == \".\" then ./. + url"
603+ , " else url;"
604+ , " in if !fetchSubmodules && private then builtins.fetchGit {"
605+ , " url = realUrl; inherit rev;"
606+ , " ${if branch == null then null else \"ref\"} = branch;"
607+ , " } else (import <nixpkgs> {}).fetchgit {"
608+ , " url = realUrl; inherit rev sha256;"
609+ , " };"
610+ , "in import (fetch (builtins.fromJSON (builtins.readFile ./git.json)))"
611+ ]
612+
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+|]
655+
552656
553−--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
554659
555660-- | Checks a cache directory to see if there is a fresh symlink
556661-- to the result of building an attribute of a thunk.
@@ -558,44 +663,49 @@ thunkFileNames = ["default.nix", "github.json", "git.json"]
558663-- and the result is symlinked into the cache.
559664nixBuildThunkAttrWithCache
560665 :: MonadObelisk m
561− => FilePath
666+ => ThunkSpec
667+ -> FilePath
562668 -- ^ Path to directory containing Thunk
563669 -> String
564670 -- ^ Attribute to build
565− -> m FilePath
671+ -> m (Maybe FilePath)
566672 -- ^ Symlink to cached or built nix output
567673-- WARNING: If the thunk uses an impure reference such as '<nixpkgs>'
568674-- the caching mechanism will fail as it merely measures the modification
569675-- time of the cache link and the expression to build.
570−nixBuildThunkAttrWithCache thunkDir attr = do
571− --NB: Expects thunkDir to be normalised with no trailing path separator.
572− --This should be guaranteed by the command argument parser.
573− let cacheErrHandler e
574− | isDoesNotExistError e = return Nothing -- expected from a cache miss
575− | otherwise = putLog Error (T.pack $ displayException e) >> return Nothing
576− cacheDir = thunkDir </> ".attr-cache"
577− cachePath = cacheDir </> attr <.> "out"
676+nixBuildThunkAttrWithCache thunkSpec thunkDir attr = do
578677 latestChange <- liftIO $ do
579− createDirectoryIfMissing False cacheDir
580− let getModificationTimeMaybe = fmap rightToMaybe . try @IOError . getModificationTime
581− maximum . catMaybes <$> mapM (getModificationTimeMaybe . (thunkDir </>)) thunkFileNames
582− cacheHit <- handle cacheErrHandler $ do
583− cacheTime <- liftIO $ posixSecondsToUTCTime . realToFrac . modificationTime <$> getSymbolicLinkStatus cachePath
584− return $ if latestChange <= cacheTime
585− then Just cachePath
586− else Nothing
587− case cacheHit of
588− Just c -> return c
589− Nothing -> do
590− putLog Warning $ T.pack $ mconcat [thunkDir, ": ", attr, " not cached, building ..."]
591− _ <- nixCmd $ NixCmd_Build $ def
592− Lens.& nixBuildConfig_outLink Lens..~ OutLink_IndirectRoot cachePath
593− Lens.& nixCmdConfig_target Lens..~ Target
594− { _target_path = Just thunkDir
595− , _target_attr = Just attr
596− , _target_expr = Nothing
597− }
598− return cachePath
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+ }
599709
600710-- | Build a nix attribute, and cache the result if possible
601711nixBuildAttrWithCache
@@ -606,13 +716,15 @@ nixBuildAttrWithCache
606716 -- ^ Attribute to build
607717 -> m FilePath
608718 -- ^ Symlink to cached or built nix output
609−nixBuildAttrWithCache exprPath attr = do
610− readThunk exprPath >>= \case
611− -- Only packed thunks are cached. in particular, checkouts are not
612− Right (ThunkData_Packed _) -> nixBuildThunkAttrWithCache exprPath attr
613− _ -> nixCmd $ NixCmd_Build $ def
614− Lens.& nixBuildConfig_outLink Lens..~ OutLink_None
615− Lens.& nixCmdConfig_target Lens..~ Target
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
616728 { _target_path = Just exprPath
617729 , _target_attr = Just attr
618730 , _target_expr = Nothing
@@ -633,7 +745,7 @@ updateThunk p f = withSystemTempDirectory "obelisk-thunkptr-" $ \tmpDir -> do
633745 where
634746 copyThunkToTmp tmpDir thunkDir = readThunk thunkDir >>= \case
635747 Left err -> failWith $ "withThunkUnpacked: " <> T.pack (show err)
636− Right (ThunkData_Packed _) -> do
748+ Right ThunkData_Packed{} -> do
637749 let tmpThunk = tmpDir </> "thunk"
638750 callProcessAndLogOutput (Notice, Error) $
639751 proc cp ["-r", "-T", thunkDir, tmpThunk]
@@ -647,62 +759,81 @@ updateThunk p f = withSystemTempDirectory "obelisk-thunkptr-" $ \tmpDir -> do
647759finalMsg :: Bool -> (a -> Text) -> Maybe (a -> Text)
648760finalMsg noTrail s = if noTrail then Nothing else Just s
649761
650−unpackThunk :: MonadObelisk m => FilePath -> m ()
651−unpackThunk = unpackThunk' False
652−
653762-- | Check that we are not somewhere inside the thunk directory
654−checkThunkDirectory :: MonadObelisk m => Text -> FilePath -> m ()
655−checkThunkDirectory msg thunkDir = do
763+checkThunkDirectory :: MonadObelisk m => FilePath -> m ()
764+checkThunkDirectory thunkDir = do
656765 currentDir <- liftIO getCurrentDirectory
657766 thunkDir' <- liftIO $ canonicalizePath thunkDir
658− when (thunkDir' `L.isInfixOf` currentDir) $ failWith msg
767+ when (thunkDir' `L.isInfixOf` currentDir) $
768+ failWith [i|Can't perform thunk operations from within the thunk directory: ${thunkDir}|]
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
659778
660779unpackThunk' :: MonadObelisk m => Bool -> FilePath -> m ()
661−unpackThunk' noTrail thunkDir = checkThunkDirectory "Can't pack/unpack from within the thunk directory" thunkDir >> readThunk thunkDir >>= \case
662− Left err -> failWith $ "thunk unpack: " <> T.pack (show err)
780+unpackThunk' noTrail thunkDir = checkThunkDirectory thunkDir *> readThunk thunkDir >>= \case
781+ Left err -> failWith [i|Invalid thunk at ${thunkDir}: ${err}|]
663782 --TODO: Overwrite option that rechecks out thunk; force option to do so even if working directory is dirty
664− Right (ThunkData_Checkout _) -> failWith "thunk unpack: thunk is already unpacked"
665− Right (ThunkData_Packed tptr) -> do
783+ Right ThunkData_Checkout -> failWith [i|Thunk at ${thunkDir} is already unpacked|]
784+ Right (ThunkData_Packed _ tptr) -> do
666785 let (thunkParent, thunkName) = splitFileName thunkDir
667− withTempDirectory thunkParent thunkName $ \tmpRepo -> do
668− let obGitDir = tmpRepo </> ".git" </> "obelisk"
669− s = case _thunkPtr_source tptr of
670− ThunkSource_GitHub s' -> forgetGithub False s'
671− ThunkSource_Git s' -> s'
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
672792 withSpinner' ("Fetching thunk " <> T.pack thunkName)
673793 (finalMsg noTrail $ const $ "Fetched thunk " <> T.pack thunkName) $ do
674− let git = callProcessAndLogOutput (Notice, Notice) . gitProc tmpRepo
675− git $ [ "clone" ]
676− ++ ("--recursive" <$ guard (_gitSource_fetchSubmodules s))
677− ++ [ T.unpack $ gitUriToText $ _gitSource_url s ]
678− ++ do branch <- maybeToList $ _gitSource_branch s
679− [ "--branch", T.unpack $ untagName branch ]
680− git ["reset", "--hard", Ref.toHexString $ _thunkRev_commit $ _thunkPtr_rev tptr]
681− when (_gitSource_fetchSubmodules s) $
682− git ["submodule", "update", "--recursive", "--init"]
683−
684− liftIO $ createDirectory obGitDir
685− callProcessAndLogOutput (Notice, Error) $
686− proc cp ["-r", "-T", thunkDir </> ".", obGitDir </> "orig-thunk"]
687− callProcessAndLogOutput (Notice, Error) $
688− proc "rm" ["-r", thunkDir]
689− callProcessAndLogOutput (Notice, Error) $
690− proc "mv" ["-T", tmpRepo, thunkDir]
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"]
691821
692822--TODO: add a rollback mode to pack to the original thunk
693823packThunk :: MonadObelisk m => ThunkPackConfig -> FilePath -> m ThunkPtr
694824packThunk = packThunk' False
695825
696826packThunk' :: MonadObelisk m => Bool -> ThunkPackConfig -> FilePath -> m ThunkPtr
697−packThunk' noTrail (ThunkPackConfig force thunkConfig) thunkDir = checkThunkDirectory "Can't pack/unpack from within the thunk directory" thunkDir >> readThunk thunkDir >>= \case
698− Left err -> failWith $ T.pack $ "thunk pack: " <> show err
699− Right (ThunkData_Packed _) -> failWith "pack: thunk is already packed"
700− Right (ThunkData_Checkout _) -> do
701− withSpinner' ("Packing thunk " <> T.pack thunkDir)
702− (finalMsg noTrail $ const $ "Packed thunk " <> T.pack thunkDir) $ do
703− thunkPtr <- modifyThunkPtrByConfig thunkConfig <$> getThunkPtr (not force) thunkDir
704− callProcessAndLogOutput (Debug, Error) $ proc "rm" ["-rf", thunkDir]
705− liftIO $ createThunk thunkDir 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
706837 pure thunkPtr
707838
708839modifyThunkPtrByConfig :: ThunkConfig -> ThunkPtr -> ThunkPtr
@@ -713,29 +844,43 @@ modifyThunkPtrByConfig (ThunkConfig markPrivate') ptr = case markPrivate' of
713844 ThunkSource_GitHub s -> ThunkSource_GitHub $ s { _gitHubSource_private = markPrivate }
714845 }
715846
716−getThunkPtr :: forall m. MonadObelisk m => Bool -> FilePath -> m ThunkPtr
717−getThunkPtr checkClean thunkDir = do
718− when checkClean $ ensureCleanGitRepo thunkDir True
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
719869 "thunk pack: thunk checkout contains unsaved modifications"
720870
721871 -- Check whether there are any stashes
722− stashOutput <- readGitProcess thunkDir ["stash", "list"]
723− when checkClean $ case T.null stashOutput of
724− False -> do
872+ when checkClean $ do
873+ stashOutput <- readGitProcess thunkDir ["stash", "list"]
874+ unless (T.null stashOutput) $
725875 failWith $ T.unlines $
726876 [ "thunk pack: thunk checkout has stashes"
727877 , "git stash list:"
728878 ] ++ T.lines stashOutput
729− True -> return ()
730879
731− -- Get current branch ``
880+ -- Get current branch
732881 (mCurrentBranch, mCurrentCommit) <- do
733− b <- listToMaybe
734− <$> T.lines
735− <$> readGitProcess thunkDir ["rev-parse", "--abbrev-ref", "HEAD"]
736− c <- listToMaybe
737− <$> T.lines
738− <$> readGitProcess thunkDir ["rev-parse", "HEAD"]
882+ b <- listToMaybe . T.lines <$> readGitProcess thunkDir ["rev-parse", "--abbrev-ref", "HEAD"]
883+ c <- listToMaybe . T.lines <$> readGitProcess thunkDir ["rev-parse", "HEAD"]
739884 case b of
740885 (Just "HEAD") -> failWith $ T.unlines
741886 [ "thunk pack: You are in 'detached HEAD' state."
@@ -746,7 +891,7 @@ getThunkPtr checkClean thunkDir = do
746891
747892 -- Get information on all branches and their (optional) designated upstream
748893 -- correspondents
749− (headDump :: [Text]) <- T.lines <$> readGitProcess thunkDir
894+ headDump :: [Text] <- T.lines <$> readGitProcess thunkDir
750895 [ "for-each-ref"
751896 , "--format=%(refname:short) %(upstream:short) %(upstream:remotename)"
752897 , "refs/heads/"
@@ -792,7 +937,7 @@ getThunkPtr checkClean thunkDir = do
792937 ]
793938
794939 -- loosely by https://stackoverflow.com/questions/7773939/show-git-ahead-and-behind-info-for-all-branches-including-remotes
795− stats <- iforM headUpstream $ \branch (upstream, _remote) -> do
940+ stats <- ifor headUpstream $ \branch (upstream, _remote) -> do
796941 (stat :: [Text]) <- T.lines <$> readGitProcess thunkDir
797942 [ "rev-list", "--left-right"
798943 , T.unpack branch <> "..." <> T.unpack upstream
@@ -816,8 +961,9 @@ getThunkPtr checkClean thunkDir = do
816961 \pushed but this repo's remote tracking branches don't know it.)"
817962 ]
818963
819− -- We assume it's safe to pack the thunk at this point
820− putLog Informational "All changes safe in git remotes. OK to pack thunk."
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."
821967
822968 let remote = maybe "origin" snd $ flip Map.lookup headUpstream =<< mCurrentBranch
823969
@@ -830,14 +976,12 @@ getThunkPtr checkClean thunkDir = do
830976 remoteUri <- case parseGitUri remoteUri' of
831977 Nothing -> failWith $ "Could not identify git remote: " <> remoteUri'
832978 Just uri -> pure uri
833− uriThunkPtr remoteUri mCurrentBranch mCurrentCommit
979+ uriThunkPtr remoteUri mPrivate mCurrentBranch mCurrentCommit
834980
835981-- | Get the latest revision available from the given source
836982getLatestRev :: MonadObelisk m => ThunkSource -> m ThunkRev
837983getLatestRev os = do
838− let gitS = case os of
839− ThunkSource_GitHub s -> forgetGithub False s
840− ThunkSource_Git s -> s
984+ let gitS = thunkSourceToGitSource os
841985 (_, commit) <- gitGetCommitBranch (_gitSource_url gitS) (untagName <$> _gitSource_branch gitS)
842986 case os of
843987 ThunkSource_GitHub s -> githubThunkRev s commit
@@ -849,12 +993,12 @@ getLatestRev os = do
849993-- performance. If that doesn't work (e.g. authentication issue), we fall back
850994-- on just doing things the normal way for git repos in general, and save it as
851995-- a regular git thunk.
852−uriThunkPtr :: MonadObelisk m => GitUri -> Maybe Text -> Maybe Text -> m ThunkPtr
853−uriThunkPtr uri mbranch mcommit = do
996+uriThunkPtr :: MonadObelisk m => GitUri -> Maybe Bool -> Maybe Text -> Maybe Text -> m ThunkPtr
997+uriThunkPtr uri mPrivate mbranch mcommit = do
854998 commit <- case mcommit of
855− Nothing -> gitGetCommitBranch uri mbranch >>= return . snd -- return . (\(_, y, _)->y) --perhaps do io here instead of making uriToTHunkSource effectful ?
999+ Nothing -> gitGetCommitBranch uri mbranch >>= return . snd
8561000 (Just c) -> return c
857− (src, rev) <- uriToThunkSource uri mbranch >>= \case
1001+ (src, rev) <- uriToThunkSource uri mPrivate mbranch >>= \case
8581002 ThunkSource_GitHub s -> do
8591003 rev <- runExceptT $ githubThunkRev s commit
8601004 case rev of
@@ -877,8 +1021,8 @@ uriThunkPtr uri mbranch mcommit = do
8771021-- If the thunk is a GitHub thunk and fails, we do *not* fall back like with
8781022-- `uriThunkPtr`. Unlike a plain URL, a thunk src explicitly states which method
8791023-- should be employed, and so we respect that.
880−uriToThunkSource :: MonadObelisk m => GitUri -> Maybe Text -> m ThunkSource
881−uriToThunkSource (GitUri u)
1024+uriToThunkSource :: MonadObelisk m => GitUri -> Maybe Bool -> Maybe Text -> m ThunkSource
1025+uriToThunkSource (GitUri u) mPrivate
8821026 | Right uriAuth <- URI.uriAuthority u
8831027 , Just scheme <- URI.unRText <$> URI.uriScheme u
8841028 , case scheme of
@@ -890,40 +1034,53 @@ uriToThunkSource (GitUri u)
8901034 s -> s `L.elem` [ "git", "https", "http" ] -- "http:" just redirects to "https:"
8911035 && URI.unRText (URI.authHost uriAuth) == "github.com"
8921036 , Just (_, owner :| [repoish]) <- URI.uriPath u
893− = \mbranch ->
894− do
895− unAuthenticatedExitCode <-
896− fmap (\(x, _, _)->x)
897− . readCreateProcessWithExitCode
898− . isolateGitProc . gitProcNoRepo $
899− ["ls-remote"
900− , "--exit-code"
901− , "--symref"
902− , show $ u
903− { URI.uriScheme=URI.mkScheme "https"
904− , URI.uriAuthority=Left True}]
905− pure . ThunkSource_GitHub $ GitHubSource
1037+ = \mbranch -> do
1038+ isPrivate <- getIsPrivate
1039+ pure $ ThunkSource_GitHub $ GitHubSource
9061040 { _gitHubSource_owner = N $ URI.unRText owner
9071041 , _gitHubSource_repo = N $ let
9081042 repoish' = URI.unRText repoish
9091043 in fromMaybe repoish' $ T.stripSuffix ".git" repoish'
9101044 , _gitHubSource_branch = N <$> mbranch
911− , _gitHubSource_private = unAuthenticatedExitCode /= ExitSuccess
1045+ , _gitHubSource_private = isPrivate
9121046 }
9131047
914− | otherwise = \mbranch ->
915− do
916− unAuthenticatedExitCode <-
917− fmap (\(x, _, _)->x)
918− . readCreateProcessWithExitCode
919− . isolateGitProc . gitProcNoRepo $
920− ["ls-remote", "--exit-code", "--symref", show u]
921− pure . ThunkSource_Git $ GitSource
1048+ | otherwise = \mbranch -> do
1049+ isPrivate <- getIsPrivate
1050+ pure $ ThunkSource_Git $ GitSource
9221051 { _gitSource_url = GitUri u
9231052 , _gitSource_branch = N <$> mbranch
9241053 , _gitSource_fetchSubmodules = False -- TODO: How do we determine if this should be true?
925− , _gitSource_private = unAuthenticatedExitCode /= ExitSuccess
1054+ , _gitSource_private = isPrivate
9261055 }
1056+ where
1057+ getIsPrivate = maybe (guessGitRepoIsPrivate $ GitUri u) pure mPrivate
1058+
1059+guessGitRepoIsPrivate :: MonadObelisk m => GitUri -> m Bool
1060+guessGitRepoIsPrivate uri = flip fix urisToTry $ \loop -> \case
1061+ [] -> pure True
1062+ uriAttempt:xs -> do
1063+ result <- readCreateProcessWithExitCode $
1064+ isolateGitProc $
1065+ gitProcNoRepo
1066+ [ "ls-remote"
1067+ , "--quiet"
1068+ , "--exit-code"
1069+ , "--symref"
1070+ , T.unpack $ gitUriToText uriAttempt
1071+ ]
1072+ case result of
1073+ (ExitSuccess, _, _) -> pure False -- Must be a public repo
1074+ _ -> loop xs
1075+ where
1076+ urisToTry = nubOrd $
1077+ -- Include the original URI if it isn't using SSH because SSH will certainly fail.
1078+ [uri | fmap URI.unRText (URI.uriScheme (unGitUri uri)) /= Just "ssh"] <>
1079+ [changeScheme "https" uri, changeScheme "http" uri]
1080+ changeScheme scheme (GitUri u) = GitUri $ u
1081+ { URI.uriScheme = URI.mkScheme scheme
1082+ , URI.uriAuthority = (\x -> x { URI.authUserInfo = Nothing }) <$> URI.uriAuthority u
1083+ }
9271084
9281085-- Funny signature indicates no effects depend on the optional branch name.
9291086githubThunkRev