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