@@ -5,85 +5,70 @@
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
15− , ReadThunkError (..)
19− , updateThunkToLatest
21− , createThunkWithLatest
22− , nixBuildAttrWithCache
23− , nixBuildThunkAttrWithCache
34import Control.Applicative
13import Control.Applicative
35−import Control.Exception (displayException, throwIO, try)
14+import Control.Exception (displayException, try)
15+import Control.Lens (ifor, ifor_, (.~))
36import Control.Monad
16import Control.Monad
37−import Control.Monad.Catch (handle)
17+import Control.Monad.Extra (findM)
18+import Control.Monad.Catch (MonadCatch, handle)
38import Control.Monad.Except
19import Control.Monad.Except
39import Data.Aeson ((.=))
20import Data.Aeson ((.=))
40import qualified Data.Aeson as Aeson
21import qualified Data.Aeson as Aeson
41import Data.Aeson.Encode.Pretty
22import Data.Aeson.Encode.Pretty
42import qualified Data.Aeson.Types as Aeson
23import qualified Data.Aeson.Types as Aeson
24+import Data.Bifunctor (first)
43import qualified Data.ByteString.Lazy as LBS
25import qualified Data.ByteString.Lazy as LBS
26+import Data.Containers.ListUtils (nubOrd)
44import Data.Default
27import Data.Default
45−import Data.Either.Combinators (rightToMaybe)
28+import Data.Either.Combinators (fromRight', rightToMaybe)
46−import Data.Foldable
29+import Data.Foldable (toList)
30+import Data.Function ((&))
31+import Data.Functor ((<&>))
47import Data.Git.Ref (Ref)
32import Data.Git.Ref (Ref)
48import qualified Data.Git.Ref as Ref
33import qualified Data.Git.Ref as Ref
49import qualified Data.List as L
34import qualified Data.List as L
50−import Data.List.NonEmpty (NonEmpty (..))
35+import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
51import qualified Data.List.NonEmpty as NonEmpty
36import qualified Data.List.NonEmpty as NonEmpty
52import qualified Data.Map as Map
38import qualified Data.Map as Map
53import Data.Maybe
39import Data.Maybe
54import Data.Set (Set)
40import Data.Set (Set)
55import 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)
56import Data.Text (Text)
44import Data.Text (Text)
57import qualified Data.Text as T
45import qualified Data.Text as T
58import Data.Text.Encoding
46import Data.Text.Encoding
59import qualified Data.Text.IO as T
47import qualified Data.Text.IO as T
60import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
48import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
61−import Data.Yaml (parseMaybe, (.:))
49+import Data.Traversable (for)
62−import qualified Data.Yaml as Yaml
50+import Data.Yaml (parseMaybe)
63import GitHub
51import GitHub
64import GitHub.Data.Name
52import GitHub.Data.Name
65−import GitHub.Endpoints.Repos.Contents (archiveForR)
67import Obelisk.Command.Nix
53import Obelisk.Command.Nix
68import System.Directory
54import System.Directory
69import System.FilePath
56import System.FilePath
70import System.IO.Error
57import System.IO.Error
71import System.IO.Temp
58import System.IO.Temp
72−import System.Posix (getSymbolicLinkStatus, modificationTime)
59+import System.PosixCompat.Files (getSymbolicLinkStatus, modificationTime)
73−import System.Process (proc)
60+import qualified Text.URI as URI
75import Obelisk.App (MonadObelisk)
62import Obelisk.App (MonadObelisk)
76import Obelisk.CliApp
63import Obelisk.CliApp
77−import Obelisk.Command.Nix (withNixRemoteCheck)
78import Obelisk.Command.Utils
64import Obelisk.Command.Utils
80--TODO: Support symlinked thunk data
66--TODO: Support symlinked thunk data
81data ThunkData
67data ThunkData
82− = ThunkData_Packed ThunkPtr
68+ = ThunkData_Packed ThunkSpec ThunkPtr
83 -- ^ Packed thunk
69 -- ^ Packed thunk
84− | ThunkData_Checkout (Maybe ThunkPtr)
70+ | ThunkData_Checkout
85 -- ^ Checked out thunk that was unpacked from this pointer
71 -- ^ Checked out thunk that was unpacked from this pointer
86− deriving (Show, Eq, Ord)
88-- | 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
89data ThunkPtr = ThunkPtr
74data ThunkPtr = ThunkPtr
@@ -96,7 +81,7 @@ type NixSha256 = Text --TODO: Use a smart constructor and make this actually ver
97-- | A specific revision of data; it may be available from multiple sources
82-- | A specific revision of data; it may be available from multiple sources
98data ThunkRev = ThunkRev
83data ThunkRev = ThunkRev
99− { _thunkRev_commit :: Ref
84+ { _thunkRev_commit :: Ref Ref.SHA1
100 , _thunkRev_nixSha256 :: NixSha256
85 , _thunkRev_nixSha256 :: NixSha256
102 deriving (Show, Eq, Ord)
87 deriving (Show, Eq, Ord)
@@ -109,44 +94,99 @@ data ThunkSource
109 | ThunkSource_Git GitSource
94 | ThunkSource_Git GitSource
110 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
112data GitHubSource = GitHubSource
102data GitHubSource = GitHubSource
113 { _gitHubSource_owner :: Name Owner
103 { _gitHubSource_owner :: Name Owner
114 , _gitHubSource_repo :: Name Repo
104 , _gitHubSource_repo :: Name Repo
115 , _gitHubSource_branch :: Maybe (Name Branch)
105 , _gitHubSource_branch :: Maybe (Name Branch)
106+ , _gitHubSource_private :: Bool
117 deriving (Show, Eq, Ord)
108 deriving (Show, Eq, Ord)
110+newtype GitUri = GitUri { unGitUri :: URI.URI } deriving (Eq, Ord, Show)
112+gitUriToText :: GitUri -> Text
113+gitUriToText (GitUri uri)
114+ | (T.toLower . URI.unRText <$> URI.uriScheme uri) == Just "file"
115+ , Just (_, path) <- URI.uriPath uri
116+ = "/" <> T.intercalate "/" (map URI.unRText $ NonEmpty.toList path)
117+ | otherwise = URI.render uri
119data GitSource = GitSource
119data GitSource = GitSource
120− { _gitSource_url :: URI
120+ { _gitSource_url :: GitUri
121 , _gitSource_branch :: Maybe (Name Branch)
121 , _gitSource_branch :: Maybe (Name Branch)
122 , _gitSource_fetchSubmodules :: Bool
122 , _gitSource_fetchSubmodules :: Bool
123+ , _gitSource_private :: Bool
124 deriving (Show, Eq, Ord)
125 deriving (Show, Eq, Ord)
127+newtype ThunkConfig = ThunkConfig
128+ { _thunkConfig_private :: Maybe Bool
131+data ThunkUpdateConfig = ThunkUpdateConfig
132+ { _thunkUpdateConfig_branch :: Maybe String
133+ , _thunkUpdateConfig_config :: ThunkConfig
136+data ThunkPackConfig = ThunkPackConfig
137+ { _thunkPackConfig_force :: Bool
138+ , _thunkPackConfig_config :: ThunkConfig
141+-- | Convert a GitHub source to a regular Git source. Assumes no submodules.
142+forgetGithub :: Bool -> GitHubSource -> GitSource
143+forgetGithub useSsh s = GitSource
144+ { _gitSource_url = GitUri $ URI.URI
145+ { URI.uriScheme = Just $ fromRight' $ URI.mkScheme $ if useSsh then "ssh" else "https"
146+ , URI.uriAuthority = Right $ URI.Authority
147+ { URI.authUserInfo = URI.UserInfo (fromRight' $ URI.mkUsername "git") Nothing
149+ , URI.authHost = fromRight' $ URI.mkHost "github.com"
150+ , URI.authPort = Nothing
152+ , URI.uriPath = Just ( False
153+ , fromRight' . URI.mkPathPiece <$>
154+ untagName (_gitHubSource_owner s)
155+ :| [ untagName (_gitHubSource_repo s) <> ".git" ]
158+ , URI.uriFragment = Nothing
160+ , _gitSource_branch = _gitHubSource_branch s
161+ , _gitSource_fetchSubmodules = False
162+ , _gitSource_private = _gitHubSource_private s
126getThunkGitBranch :: ThunkPtr -> Maybe Text
165getThunkGitBranch :: ThunkPtr -> Maybe Text
127getThunkGitBranch (ThunkPtr _ src) = fmap untagName $ case src of
166getThunkGitBranch (ThunkPtr _ src) = fmap untagName $ case src of
128 ThunkSource_GitHub s -> _gitHubSource_branch s
167 ThunkSource_GitHub s -> _gitHubSource_branch s
129 ThunkSource_Git s -> _gitSource_branch s
168 ThunkSource_Git s -> _gitSource_branch s
131−commitNameToRef :: Name Commit -> Ref
170+commitNameToRef :: Name Commit -> Ref Ref.SHA1
132commitNameToRef (N c) = Ref.fromHex $ encodeUtf8 c
171commitNameToRef (N c) = Ref.fromHex $ encodeUtf8 c
134-- TODO: Use spinner here.
173-- TODO: Use spinner here.
135getNixSha256ForUriUnpacked
174getNixSha256ForUriUnpacked
136 :: MonadObelisk m
175 :: MonadObelisk m
137− => URI
176+ => GitUri
138 -> m NixSha256
177 -> m NixSha256
139getNixSha256ForUriUnpacked uri =
178getNixSha256ForUriUnpacked uri =
140− withExitFailMessage ("nix-prefetch-url: Failed to determine sha256 hash of URL " <> T.pack (show uri)) $ do
179+ withExitFailMessage ("nix-prefetch-url: Failed to determine sha256 hash of URL " <> gitUriToText uri) $ do
141− withNixRemoteCheck $ readProcessAndLogStderr Debug $
180+ [hash] <- fmap T.lines $ readProcessAndLogOutput (Debug, Debug) $
142− proc "nix-prefetch-url" ["--unpack" , "--type" , "sha256" , show uri]
181+ proc nixPrefetchUrlPath ["--unpack", "--type", "sha256", T.unpack $ gitUriToText uri]
144−nixPrefetchGit :: MonadObelisk m => URI -> Text -> Bool -> m NixSha256
184+nixPrefetchGit :: MonadObelisk m => GitUri -> Text -> Bool -> m NixSha256
145nixPrefetchGit uri rev fetchSubmodules =
185nixPrefetchGit uri rev fetchSubmodules =
146− withExitFailMessage ("nix-prefetch-git: Failed to determine sha256 hash of Git repo " <> T.pack (show uri) <> " at " <> rev) $ do
186+ withExitFailMessage ("nix-prefetch-git: Failed to determine sha256 hash of Git repo " <> gitUriToText uri <> " at " <> rev) $ do
147− out <- withNixRemoteCheck $ readProcessAndLogStderr Debug $
187+ out <- readProcessAndLogStderr Debug $
148− proc "nix-prefetch-git" $ filter (/="")
188+ proc nixPrefetchGitPath $ filter (/="")
149− [ "--url", show uri
189+ [ "--url", T.unpack $ gitUriToText uri
150 , "--rev", T.unpack rev
190 , "--rev", T.unpack rev
151 , if fetchSubmodules then "--fetch-submodules" else ""
191 , if fetchSubmodules then "--fetch-submodules" else ""
152 , "--quiet"
192 , "--quiet"
@@ -156,130 +196,119 @@ nixPrefetchGit uri rev fetchSubmodules =
156 Nothing -> failWith $ "nix-prefetch-git: unrecognized output " <> out
196 Nothing -> failWith $ "nix-prefetch-git: unrecognized output " <> out
157 Just x -> pure x
197 Just x -> pure x
159−getLatestGitRev :: MonadObelisk m => GitSource -> m ThunkRev
160−getLatestGitRev s = do
161− (_, commit) <- gitGetCommitBranch (_gitSource_url s) (untagName <$> _gitSource_branch s)
162− sha <- nixPrefetchGit (_gitSource_url s) commit (_gitSource_fetchSubmodules s)
163− putLog Debug $ "Nix sha256 is " <> sha
165− { _thunkRev_commit = Ref.fromHexString $ T.unpack commit
166− , _thunkRev_nixSha256 = sha
169−-- | Get the latest revision available from the given source
170−getLatestRev :: MonadObelisk m => ThunkSource -> m ThunkRev
172− ThunkSource_GitHub s -> do
173− auth <- liftIO $ getHubAuth "github.com"
174− commitsResult <- liftIO $ executeRequestMaybe auth $ commitsWithOptionsForR
175− (_gitHubSource_owner s)
176− (_gitHubSource_repo s)
178− $ case _gitHubSource_branch s of
180− Just b -> [CommitQuerySha $ untagName b]
181− commitInfos <- either (liftIO . throwIO) return commitsResult
182− commitInfo : _ <- return $ toList commitInfos
183− let commit = commitSha commitInfo
184− putLog Debug $ "Latest commit is " <> untagName commit
185− Right archiveUri <- liftIO $ executeRequestMaybe auth $ archiveForR (_gitHubSource_owner s) (_gitHubSource_repo s) ArchiveFormatTarball $ Just $ untagName commit
186− nixSha256 <- getNixSha256ForUriUnpacked archiveUri
187− putLog Debug $ "Nix sha256 is " <> nixSha256
189− { _thunkRev_commit = commitNameToRef commit
190− , _thunkRev_nixSha256 = nixSha256
192− ThunkSource_Git s -> getLatestGitRev s
194--TODO: Pretty print these
199--TODO: Pretty print these
195data ReadThunkError
200data ReadThunkError
196− = ReadThunkError_UnrecognizedFiles
201+ = ReadThunkError_UnrecognizedThunk
197− | ReadThunkError_AmbiguousFiles
202+ | ReadThunkError_UnrecognizedPaths (NonEmpty FilePath)
198− | ReadThunkError_UnrecognizedLoader Text
203+ | ReadThunkError_MissingPaths (NonEmpty FilePath)
199− | ReadThunkError_UnparseablePtr LBS.ByteString
204+ | ReadThunkError_UnparseablePtr FilePath String
200− deriving (Show)
205+ | ReadThunkError_FileError IOError
201−
206+ | ReadThunkError_FileDoesNotMatch FilePath Text
202−-- | Read a thunk and validate that it is only a thunk, either packed or unpacked.
207+ | ReadThunkError_UnrecognizedState String
203−-- If the thunk is packed and additional data is present, fail.
208+ | ReadThunkError_AmbiguousPackedState ThunkPtr ThunkPtr
204−readThunk :: MonadObelisk m => FilePath -> m (Either ReadThunkError ThunkData)
209+ deriving (Show)
205−readThunk thunkDir = do
210+
206− files <- liftIO $ listDirectory thunkDir
211+unpackedDirName :: FilePath
207− case ".git" `elem` files of
212+unpackedDirName = "."
208− True -> fmap ThunkData_Checkout <$> do
213+
209− let origThunkPath = thunkDir </> ".git" </> "obelisk" </> "orig-thunk"
214+attrCacheFileName :: FilePath
210− liftIO $ doesDirectoryExist origThunkPath >>= \case
215+attrCacheFileName = ".attr-cache"
211− True -> fmap Just <$> readPackedThunk origThunkPath
216+
212− False -> return $ return Nothing
217+-- | Specification for how a file in a thunk version works.
213− False -> liftIO $ fmap ThunkData_Packed <$> readPackedThunk thunkDir
218+data ThunkFileSpec
214−
219+ = ThunkFileSpec_Ptr (LBS.ByteString -> Either String ThunkPtr) -- ^ This file specifies 'ThunkPtr' data
215−data ThunkType = ThunkType
220+ | ThunkFileSpec_FileMatches Text -- ^ This file must match the given content exactly
216− { _thunkType_loader :: FilePath
221+ | ThunkFileSpec_CheckoutIndicator -- ^ Existence of this directory indicates that the thunk is unpacked
217− , _thunkType_json :: FilePath
222+ | ThunkFileSpec_AttrCache -- ^ This directory is an attribute cache
218− , _thunkType_optional :: Set FilePath
223+
219− , _thunkType_loaderVersions :: NonEmpty Text
224+-- | Specification for how a set of files in a thunk version work.
220− , _thunkType_parser :: Aeson.Object -> Aeson.Parser ThunkPtr
225+data ThunkSpec = ThunkSpec
221− }
226+ { _thunkSpec_name :: !Text
222−
227+ , _thunkSpec_files :: !(Map FilePath ThunkFileSpec)
223−gitHubThunkType :: ThunkType
224−gitHubThunkType = ThunkType
225− { _thunkType_loader = "default.nix"
226− , _thunkType_json = "github.json"
227− , _thunkType_optional = Set.fromList [".attr-cache"]
228− , _thunkType_loaderVersions = gitHubStandaloneLoaders
229− , _thunkType_parser = parseThunkPtr $ \v ->
230− ThunkSource_GitHub <$> parseGitHubSource v <|> ThunkSource_Git <$> parseGitSource v
233−gitThunkType :: ThunkType
230+thunkSpecTypes :: NonEmpty (NonEmpty ThunkSpec)
234−gitThunkType = ThunkType
231+thunkSpecTypes = gitThunkSpecs :| [gitHubThunkSpecs]
235− { _thunkType_loader = "default.nix"
232+
236− , _thunkType_json = "git.json"
233+-- | Attempts to match a 'ThunkSpec' to a given directory.
237− , _thunkType_optional = Set.fromList [".attr-cache"]
234+matchThunkSpecToDir
238− , _thunkType_loaderVersions = plainGitStandaloneLoaders
235+ :: (MonadError ReadThunkError m, MonadIO m, MonadCatch m)
239− , _thunkType_parser = parseThunkPtr $ fmap ThunkSource_Git . parseGitSource
236+ => ThunkSpec -- ^ 'ThunkSpec' to match against the given files/directory
240− }
237+ -> FilePath -- ^ Path to directory
241−
238+ -> Set FilePath -- ^ Set of file paths relative to the given directory
242−thunkTypes :: [ThunkType]
239+ -> m ThunkData
243−thunkTypes = [gitThunkType, gitHubThunkType]
240+matchThunkSpecToDir thunkSpec dir dirFiles = do
244−
241+ case nonEmpty (toList $ dirFiles `Set.difference` expectedPaths) of
245−findThunkType :: [ThunkType] -> FilePath -> IO (Either ReadThunkError ThunkType)
242+ Just fs -> throwError $ ReadThunkError_UnrecognizedPaths $ (dir </>) <$> fs
246−findThunkType types thunkDir = do
243+ Nothing -> pure ()
247− matches <- fmap catMaybes $ forM types $ \thunkType -> do
244+ case nonEmpty (toList $ requiredPaths `Set.difference` dirFiles) of
248− let
245+ Just fs -> throwError $ ReadThunkError_MissingPaths $ (dir </>) <$> fs
249− expectedContents = Set.fromList $ (thunkDir </>) <$>
246+ Nothing -> pure ()
250− [ _thunkType_loader thunkType
247+ datas <- fmap toList $ flip Map.traverseMaybeWithKey (_thunkSpec_files thunkSpec) $ \expectedPath -> \case
251− , _thunkType_json thunkType
248+ ThunkFileSpec_AttrCache -> Nothing <$ dirMayExist expectedPath
252− ]
249+ ThunkFileSpec_CheckoutIndicator -> liftIO (doesDirectoryExist (dir </> expectedPath)) <&> \case
253− optionalContents = Set.map (thunkDir </>) (_thunkType_optional thunkType)
250+ False -> Nothing
254−
251+ True -> Just ThunkData_Checkout
255− -- Ensure that there aren't any other files in the thunk
252+ ThunkFileSpec_FileMatches expectedContents -> handle (\(e :: IOError) -> throwError $ ReadThunkError_FileError e) $ do
256− -- NB: System.Directory.listDirectory returns the contents without the directory path
253+ actualContents <- liftIO (T.readFile $ dir </> expectedPath)
257− files <- liftIO $ Set.fromList . fmap (thunkDir </>) <$> listDirectory thunkDir
254+ case T.strip expectedContents == T.strip actualContents of
258− let unexpectedContents = files `Set.difference` (expectedContents `Set.union` optionalContents)
255+ True -> pure Nothing
259− missingContents = expectedContents `Set.difference` files
256+ False -> throwError $ ReadThunkError_FileDoesNotMatch (dir </> expectedPath) expectedContents
260− pure $ if Set.null unexpectedContents && Set.null missingContents
257+ ThunkFileSpec_Ptr parser -> handle (\(e :: IOError) -> throwError $ ReadThunkError_FileError e) $ do
261− then Just thunkType
258+ let path = dir </> expectedPath
262− else Nothing
259+ liftIO (doesFileExist path) >>= \case
263−
260+ False -> pure Nothing
264− pure $ case matches of
261+ True -> do
265− [singleMatch] -> Right singleMatch
262+ actualContents <- liftIO $ LBS.readFile path
266− [] -> Left ReadThunkError_UnrecognizedFiles
263+ case parser actualContents of
267− _ -> Left ReadThunkError_AmbiguousFiles
264+ Right v -> pure $ Just (ThunkData_Packed thunkSpec v)
265+ Left e -> throwError $ ReadThunkError_UnparseablePtr (dir </> expectedPath) e
267+ case nonEmpty datas of
268+ Nothing -> throwError ReadThunkError_UnrecognizedThunk
269+ Just xs -> fold1WithM xs $ \a b -> either throwError pure (mergeThunkData a b)
271+ rootPathsOnly = Set.fromList . mapMaybe takeRootDir . Map.keys
272+ takeRootDir = fmap NonEmpty.head . nonEmpty . splitPath
274+ expectedPaths = rootPathsOnly $ _thunkSpec_files thunkSpec
276+ requiredPaths = rootPathsOnly $ Map.filter isRequiredFileSpec $ _thunkSpec_files thunkSpec
277+ isRequiredFileSpec = \case
278+ ThunkFileSpec_FileMatches _ -> True
281+ dirMayExist expectedPath = liftIO (doesFileExist (dir </> expectedPath)) >>= \case
282+ True -> throwError $ ReadThunkError_UnrecognizedPaths $ expectedPath :| []
285+ -- Combine 'ThunkData' from different files, preferring "Checkout" over "Packed"
286+ mergeThunkData ThunkData_Checkout ThunkData_Checkout = Right ThunkData_Checkout
287+ mergeThunkData ThunkData_Checkout ThunkData_Packed{} = Left bothPackedAndUnpacked
288+ mergeThunkData ThunkData_Packed{} ThunkData_Checkout = Left bothPackedAndUnpacked
289+ mergeThunkData a@(ThunkData_Packed _ ptrA) (ThunkData_Packed _ ptrB) =
290+ if ptrA == ptrB then Right a else Left $ ReadThunkError_AmbiguousPackedState ptrA ptrB
292+ bothPackedAndUnpacked = ReadThunkError_UnrecognizedState "Both packed data and checkout present"
294+ fold1WithM (x :| xs) f = foldM f x xs
298+ => NonEmpty (NonEmpty ThunkSpec) -> FilePath -> m (Either ReadThunkError ThunkData)
299+readThunkWith specTypes dir = do
300+ dirFiles <- Set.fromList <$> liftIO (listDirectory dir)
301+ let specs = concatMap toList $ toList $ NonEmpty.transpose specTypes -- Interleave spec types so we try each one in a "fair" ordering
302+ flip fix specs $ \loop -> \case
303+ [] -> pure $ Left ReadThunkError_UnrecognizedThunk
304+ spec:rest -> runExceptT (matchThunkSpecToDir spec dir dirFiles) >>= \case
305+ Left e -> putLog Debug [i|Thunk specification ${_thunkSpec_name spec} did not match ${dir}: ${e}|] *> loop rest
306+ x@(Right _) -> x <$ putLog Debug [i|Thunk specification ${_thunkSpec_name spec} matched ${dir}|]
269-- | 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.
270-- If additional data is present, fail.
309-- If additional data is present, fail.
271−readPackedThunk :: FilePath -> IO (Either ReadThunkError ThunkPtr)
310+readThunk :: (MonadObelisk m) => FilePath -> m (Either ReadThunkError ThunkData)
272−readPackedThunk thunkDir = runExceptT $ do
311+readThunk = readThunkWith thunkSpecTypes
273− thunkType <- ExceptT $ findThunkType thunkTypes thunkDir
274− -- Ensure that we recognize the thunk loader
275− loader <- liftIO $ T.readFile $ thunkDir </> _thunkType_loader thunkType
276− unless (loader `elem` _thunkType_loaderVersions thunkType) $ do
277− throwError $ ReadThunkError_UnrecognizedLoader loader
279− txt <- liftIO $ LBS.readFile $ thunkDir </> _thunkType_json thunkType
280− case parseMaybe (_thunkType_parser thunkType) =<< Aeson.decode txt of
281− Nothing -> throwError $ ReadThunkError_UnparseablePtr txt
282− Just ptr -> return ptr
284parseThunkPtr :: (Aeson.Object -> Aeson.Parser ThunkSource) -> Aeson.Object -> Aeson.Parser ThunkPtr
313parseThunkPtr :: (Aeson.Object -> Aeson.Parser ThunkSource) -> Aeson.Object -> Aeson.Parser ThunkPtr
285parseThunkPtr parseSrc v = do
314parseThunkPtr parseSrc v = do
@@ -299,10 +328,12 @@ parseGitHubSource v = do
299 owner <- v Aeson..: "owner"
328 owner <- v Aeson..: "owner"
300 repo <- v Aeson..: "repo"
329 repo <- v Aeson..: "repo"
301 branch <- v Aeson..:! "branch"
330 branch <- v Aeson..:! "branch"
331+ private <- v Aeson..:? "private"
302 pure $ GitHubSource
332 pure $ GitHubSource
303 { _gitHubSource_owner = owner
333 { _gitHubSource_owner = owner
304 , _gitHubSource_repo = repo
334 , _gitHubSource_repo = repo
305 , _gitHubSource_branch = branch
335 , _gitHubSource_branch = branch
336+ , _gitHubSource_private = fromMaybe False private
308parseGitSource :: Aeson.Object -> Aeson.Parser GitSource
339parseGitSource :: Aeson.Object -> Aeson.Parser GitSource
@@ -310,25 +341,29 @@ parseGitSource v = do
310 Just url <- parseGitUri <$> v Aeson..: "url"
341 Just url <- parseGitUri <$> v Aeson..: "url"
311 branch <- v Aeson..:! "branch"
342 branch <- v Aeson..:! "branch"
312 fetchSubmodules <- v Aeson..:! "fetchSubmodules"
343 fetchSubmodules <- v Aeson..:! "fetchSubmodules"
344+ private <- v Aeson..:? "private"
313 pure $ GitSource
345 pure $ GitSource
314 { _gitSource_url = url
346 { _gitSource_url = url
315 , _gitSource_branch = branch
347 , _gitSource_branch = branch
316 , _gitSource_fetchSubmodules = fromMaybe False fetchSubmodules
348 , _gitSource_fetchSubmodules = fromMaybe False fetchSubmodules
349+ , _gitSource_private = fromMaybe False private
319overwriteThunk :: MonadObelisk m => FilePath -> ThunkPtr -> m ()
352overwriteThunk :: MonadObelisk m => FilePath -> ThunkPtr -> m ()
320overwriteThunk target thunk = do
353overwriteThunk target thunk = do
321 -- 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)
322− Right _ <- readThunk target
355+ readThunk target >>= \case
356+ Left e -> failWith [i|Invalid thunk at ${target}: ${e}|]
324 --TODO: Is there a safer way to do this overwriting?
359 --TODO: Is there a safer way to do this overwriting?
325− liftIO $ removeDirectoryRecursive target
360+ liftIO $ removePathForcibly target
326− liftIO $ createThunk target thunk
361+ createThunk target $ Right thunk
328−thunkPtrLoader :: ThunkPtr -> Text
363+thunkPtrToSpec :: ThunkPtr -> ThunkSpec
329−thunkPtrLoader thunk = case _thunkPtr_source thunk of
364+thunkPtrToSpec thunk = case _thunkPtr_source thunk of
330− ThunkSource_GitHub _ -> NonEmpty.head gitHubStandaloneLoaders
365+ ThunkSource_GitHub _ -> NonEmpty.head gitHubThunkSpecs
331− ThunkSource_Git _ -> NonEmpty.head plainGitStandaloneLoaders
366+ ThunkSource_Git _ -> NonEmpty.head gitThunkSpecs
333-- It's important that formatting be very consistent here, because
368-- It's important that formatting be very consistent here, because
334-- otherwise when people update thunks, their patches will be messy
369-- otherwise when people update thunks, their patches will be messy
@@ -340,14 +375,15 @@ encodeThunkPtrData (ThunkPtr rev src) = case src of
340 , ("branch" .=) <$> _gitHubSource_branch s
375 , ("branch" .=) <$> _gitHubSource_branch s
341 , Just $ "rev" .= Ref.toHexString (_thunkRev_commit rev)
376 , Just $ "rev" .= Ref.toHexString (_thunkRev_commit rev)
342 , Just $ "sha256" .= _thunkRev_nixSha256 rev
377 , Just $ "sha256" .= _thunkRev_nixSha256 rev
378+ , Just $ "private" .= _gitHubSource_private s
344 ThunkSource_Git s -> encodePretty' plainGitCfg $ Aeson.object $ catMaybes
380 ThunkSource_Git s -> encodePretty' plainGitCfg $ Aeson.object $ catMaybes
345− --TODO: Is this safe? read/show is jank for `URI`
381+ [ Just $ "url" .= gitUriToText (_gitSource_url s)
346− [ Just $ "url" .= show (_gitSource_url s)
347 , Just $ "rev" .= Ref.toHexString (_thunkRev_commit rev)
382 , Just $ "rev" .= Ref.toHexString (_thunkRev_commit rev)
348 , ("branch" .=) <$> _gitSource_branch s
383 , ("branch" .=) <$> _gitSource_branch s
349 , Just $ "sha256" .= _thunkRev_nixSha256 rev
384 , Just $ "sha256" .= _thunkRev_nixSha256 rev
350 , Just $ "fetchSubmodules" .= _gitSource_fetchSubmodules s
385 , Just $ "fetchSubmodules" .= _gitSource_fetchSubmodules s
386+ , Just $ "private" .= _gitSource_private s
353 githubCfg = defConfig
389 githubCfg = defConfig
@@ -368,59 +404,84 @@ encodeThunkPtrData (ThunkPtr rev src) = case src of
370 , "sha256"
406 , "sha256"
371 , "fetchSubmodules"
408 , "fetchSubmodules"
372 ] <> compare
409 ] <> compare
373 , confTrailingNewline = True
410 , confTrailingNewline = True
376−createThunk :: MonadIO m => FilePath -> ThunkPtr -> m ()
413+createThunk :: MonadObelisk m => FilePath -> Either ThunkSpec ThunkPtr -> m ()
377−createThunk target thunk = liftIO $ do
414+createThunk target ptrInfo =
378− createDirectoryIfMissing True (target </> ".attr-cache")
415+ ifor_ (_thunkSpec_files spec) $ \path -> \case
379− T.writeFile (target </> "default.nix") (thunkPtrLoader thunk)
416+ ThunkFileSpec_FileMatches content -> withReadyPath path $ \p -> liftIO $ T.writeFile p content
380− let
417+ ThunkFileSpec_Ptr _ -> case ptrInfo of
381− jsonFileName = case _thunkPtr_source thunk of
418+ Left _ -> pure () -- We can't write the ptr without it
382− ThunkSource_GitHub _ -> "github"
419+ Right ptr -> withReadyPath path $ \p -> liftIO $ LBS.writeFile p (encodeThunkPtrData ptr)
383− ThunkSource_Git _ -> "git"
420+ _ -> pure ()
384− LBS.writeFile (target </> jsonFileName <.> "json") (encodeThunkPtrData thunk)
421+ where
422+ spec = either id thunkPtrToSpec ptrInfo
423+ withReadyPath path f = do
424+ let fullPath = target </> path
425+ putLog Debug $ "Writing thunk file " <> T.pack fullPath
426+ liftIO $ createDirectoryIfMissing True $ takeDirectory fullPath
386createThunkWithLatest :: MonadObelisk m => FilePath -> ThunkSource -> m ()
429createThunkWithLatest :: MonadObelisk m => FilePath -> ThunkSource -> m ()
387createThunkWithLatest target s = do
430createThunkWithLatest target s = do
388 rev <- getLatestRev s
431 rev <- getLatestRev s
389− createThunk target $ ThunkPtr
432+ createThunk target $ Right $ ThunkPtr
390 { _thunkPtr_source = s
433 { _thunkPtr_source = s
391 , _thunkPtr_rev = rev
434 , _thunkPtr_rev = rev
394−updateThunkToLatest :: MonadObelisk m => FilePath -> m ()
437+updateThunkToLatest :: MonadObelisk m => ThunkUpdateConfig -> FilePath -> m ()
395−updateThunkToLatest 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
396− (overwrite, ptr) <- readThunk target >>= \case
439+ checkThunkDirectory target
397− Left err -> failWith $ T.pack $ "thunk update: " <> show err
440+ -- check to see if thunk should be updated to a specific branch or just update it's current branch
398− Right c -> case c of
441+ case mBranch of
399− ThunkData_Packed t -> return (target, t)
442+ Nothing -> do
400− ThunkData_Checkout _ -> failWith "cannot update an unpacked thunk"
443+ (overwrite, ptr) <- readThunk target >>= \case
401− let src = _thunkPtr_source ptr
444+ Left err -> failWith [i|Thunk update: ${err}|]
402− rev <- getLatestRev src
445+ Right c -> case c of
403− overwriteThunk overwrite $ ThunkPtr
446+ ThunkData_Packed _ t -> return (target, t)
404− { _thunkPtr_source = src
447+ ThunkData_Checkout -> failWith "cannot update an unpacked thunk"
405− , _thunkPtr_rev = rev
448+ let src = _thunkPtr_source ptr
406− }
449+ rev <- getLatestRev src
450+ overwriteThunk overwrite $ modifyThunkPtrByConfig thunkConfig $ ThunkPtr
451+ { _thunkPtr_source = src
452+ , _thunkPtr_rev = rev
454+ Just branch -> readThunk target >>= \case
455+ Left err -> failWith [i|Thunk update: ${err}|]
456+ Right c -> case c of
457+ ThunkData_Packed _ t -> setThunk thunkConfig target (thunkSourceToGitSource $ _thunkPtr_source t) branch
458+ ThunkData_Checkout -> failWith [i|Thunk located at ${target} is unpacked. Use 'ob thunk pack' on the desired directory and then try 'ob thunk update' again.|]
460+ spinner = withSpinner' ("Updating thunk " <> T.pack target <> " to latest") (pure $ const $ "Thunk " <> T.pack target <> " updated to latest")
462+setThunk :: MonadObelisk m => ThunkConfig -> FilePath -> GitSource -> String -> m ()
463+setThunk thunkConfig target gs branch = do
464+ newThunkPtr <- uriThunkPtr (_gitSource_url gs) (_thunkConfig_private thunkConfig) (Just $ T.pack branch) Nothing
465+ overwriteThunk target newThunkPtr
466+ updateThunkToLatest (ThunkUpdateConfig Nothing thunkConfig) target
408-- | All recognized github standalone loaders, ordered from newest to oldest.
468-- | All recognized github standalone loaders, ordered from newest to oldest.
409-- 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.
410−gitHubStandaloneLoaders :: NonEmpty Text
470+gitHubThunkSpecs :: NonEmpty ThunkSpec
411−gitHubStandaloneLoaders =
471+gitHubThunkSpecs =
412− gitHubStandaloneLoaderV2 :|
472+ gitHubThunkSpecV5 :|
413− [ gitHubStandaloneLoaderV3
473+ [ gitHubThunkSpecV4
414− , gitHubStandaloneLoaderV1
474+ , gitHubThunkSpecV3
417−gitHubStandaloneLoaderV1 :: Text
479+gitHubThunkSpecV1 :: ThunkSpec
418−gitHubStandaloneLoaderV1 = T.unlines
480+gitHubThunkSpecV1 = legacyGitHubThunkSpec "github-v1"
419− [ "import ((import <nixpkgs> {}).fetchFromGitHub (builtins.fromJSON (builtins.readFile ./github.json)))"
481+ "import ((import <nixpkgs> {}).fetchFromGitHub (builtins.fromJSON (builtins.readFile ./github.json)))"
422−gitHubStandaloneLoaderV2 :: Text
483+gitHubThunkSpecV2 :: ThunkSpec
423−gitHubStandaloneLoaderV2 = T.unlines
484+gitHubThunkSpecV2 = legacyGitHubThunkSpec "github-v2" $ T.unlines
424 [ "# 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.
425 , "import ((import <nixpkgs> {}).fetchFromGitHub ("
486 , "import ((import <nixpkgs> {}).fetchFromGitHub ("
426 , " let json = builtins.fromJSON (builtins.readFile ./github.json);"
487 , " let json = builtins.fromJSON (builtins.readFile ./github.json);"
@@ -430,8 +491,8 @@ gitHubStandaloneLoaderV2 = T.unlines
433−gitHubStandaloneLoaderV3 :: Text
494+gitHubThunkSpecV3 :: ThunkSpec
434−gitHubStandaloneLoaderV3 = T.unlines
495+gitHubThunkSpecV3 = legacyGitHubThunkSpec "github-v3" $ T.unlines
435 [ "# DO NOT HAND-EDIT THIS FILE"
496 [ "# DO NOT HAND-EDIT THIS FILE"
437 , " fetch = { private ? false, ... }@args: if private && builtins.hasAttr \"fetchGit\" builtins"
498 , " fetch = { private ? false, ... }@args: if private && builtins.hasAttr \"fetchGit\" builtins"
@@ -450,22 +511,62 @@ gitHubStandaloneLoaderV3 = T.unlines
450 , "in import (fetch (builtins.fromJSON (builtins.readFile ./github.json)))"
511 , "in import (fetch (builtins.fromJSON (builtins.readFile ./github.json)))"
453−plainGitStandaloneLoaders :: NonEmpty Text
514+gitHubThunkSpecV4 :: ThunkSpec
454−plainGitStandaloneLoaders =
515+gitHubThunkSpecV4 = legacyGitHubThunkSpec "github-v4" $ T.unlines
455− plainGitStandaloneLoaderV1 :|
516+ [ "# DO NOT HAND-EDIT THIS FILE"
456− [ plainGitStandaloneLoaderV2
517+ , "let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }:"
518+ , " if !fetchSubmodules && !private then builtins.fetchTarball {"
519+ , " url = \"https://github.com/${owner}/${repo}/archive/${rev}.tar.gz\"; inherit sha256;"
520+ , " } else (import <nixpkgs> {}).fetchFromGitHub {"
521+ , " inherit owner repo rev sha256 fetchSubmodules private;"
523+ , "in import (fetch (builtins.fromJSON (builtins.readFile ./github.json)))"
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)
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
459−plainGitStandaloneLoaderV1 :: Text
560+gitThunkSpecV1 :: ThunkSpec
460−plainGitStandaloneLoaderV1 = T.unlines
561+gitThunkSpecV1 = legacyGitThunkSpec "git-v1" $ T.unlines
461 [ "# DO NOT HAND-EDIT THIS FILE"
562 [ "# DO NOT HAND-EDIT THIS FILE"
462 , "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}:"
463 , " assert !fetchSubmodules; (import <nixpkgs> {}).fetchgit { inherit url rev sha256; };"
564 , " assert !fetchSubmodules; (import <nixpkgs> {}).fetchgit { inherit url rev sha256; };"
464 , "in import (fetchGit (builtins.fromJSON (builtins.readFile ./git.json)))"
565 , "in import (fetchGit (builtins.fromJSON (builtins.readFile ./git.json)))"
467−plainGitStandaloneLoaderV2 :: Text
568+gitThunkSpecV2 :: ThunkSpec
468−plainGitStandaloneLoaderV2 = T.unlines
569+gitThunkSpecV2 = legacyGitThunkSpec "git-v2" $ T.unlines
469 [ "# DO NOT HAND-EDIT THIS FILE"
570 [ "# DO NOT HAND-EDIT THIS FILE"
470 , "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}:"
471 , " if builtins.hasAttr \"fetchGit\" builtins"
572 , " if builtins.hasAttr \"fetchGit\" builtins"
@@ -474,24 +575,87 @@ plainGitStandaloneLoaderV2 = T.unlines
474 , "in import (fetchGit (builtins.fromJSON (builtins.readFile ./git.json)))"
575 , "in import (fetchGit (builtins.fromJSON (builtins.readFile ./git.json)))"
477−thunkFileNames :: [FilePath]
578+-- This loader has a bug because @builtins.fetchGit@ is not given a @ref@
478−thunkFileNames = ["default.nix", "github.json", "git.json"]
579+-- and will fail to find commits without this because it does shallow clones.
479−
580+gitThunkSpecV3 :: ThunkSpec
480−-- | Look for authentication info from the 'hub' command
581+gitThunkSpecV3 = legacyGitThunkSpec "git-v3" $ T.unlines
481−getHubAuth
582+ [ "# DO NOT HAND-EDIT THIS FILE"
482− :: Text -- ^ Domain name
583+ , "let fetch = {url, rev, ref ? null, sha256 ? null, fetchSubmodules ? false, private ? false, ...}:"
483− -> IO (Maybe Auth)
584+ , " let realUrl = let firstChar = builtins.substring 0 1 url; in"
484−getHubAuth domain = do
585+ , " if firstChar == \"/\" then /. + url"
485− hubConfig <- getXdgDirectory XdgConfig "hub"
586+ , " else if firstChar == \".\" then ./. + url"
486− Yaml.decodeFileEither hubConfig >>= \case
587+ , " else url;"
487− Left _ -> return Nothing
588+ , " in if !fetchSubmodules && private then builtins.fetchGit {"
488− Right v -> return $ flip parseMaybe v $ \v' -> do
589+ , " url = realUrl; inherit rev;"
489− Yaml.Array domainConfigs <- v' .: domain --TODO: Determine what multiple domainConfigs means
590+ , " } else (import <nixpkgs> {}).fetchgit {"
490− [Yaml.Object domainConfig] <- return $ toList domainConfigs
591+ , " url = realUrl; inherit rev sha256;"
491− token <- domainConfig .: "oauth_token"
592+ , " };"
492− return $ OAuth $ encodeUtf8 token
593+ , "in import (fetch (builtins.fromJSON (builtins.readFile ./git.json)))"
494−--TODO: when checking something out, make a shallow clone
595+
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"
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)
657+parseJsonObject :: (Aeson.Object -> Aeson.Parser a) -> LBS.ByteString -> Either String a
658+parseJsonObject p bytes = Aeson.parseEither p =<< Aeson.eitherDecode bytes
496-- | 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
497-- to the result of building an attribute of a thunk.
661-- to the result of building an attribute of a thunk.
@@ -499,44 +663,49 @@ getHubAuth domain = do
499-- and the result is symlinked into the cache.
663-- and the result is symlinked into the cache.
500nixBuildThunkAttrWithCache
664nixBuildThunkAttrWithCache
501 :: MonadObelisk m
665 :: MonadObelisk m
502− => FilePath
666+ => ThunkSpec
503 -- ^ Path to directory containing Thunk
668 -- ^ Path to directory containing Thunk
504 -> String
669 -> String
505 -- ^ Attribute to build
670 -- ^ Attribute to build
506− -> m FilePath
671+ -> m (Maybe FilePath)
507 -- ^ Symlink to cached or built nix output
672 -- ^ Symlink to cached or built nix output
508-- WARNING: If the thunk uses an impure reference such as '<nixpkgs>'
673-- WARNING: If the thunk uses an impure reference such as '<nixpkgs>'
509-- the caching mechanism will fail as it merely measures the modification
674-- the caching mechanism will fail as it merely measures the modification
510-- time of the cache link and the expression to build.
675-- time of the cache link and the expression to build.
511−nixBuildThunkAttrWithCache thunkDir attr = do
676+nixBuildThunkAttrWithCache thunkSpec thunkDir attr = do
512− --NB: Expects thunkDir to be normalised with no trailing path separator.
513− --This should be guaranteed by the command argument parser.
514− let cacheErrHandler e
515− | isDoesNotExistError e = return Nothing -- expected from a cache miss
516− | otherwise = putLog Error (T.pack $ displayException e) >> return Nothing
517− cacheDir = thunkDir </> ".attr-cache"
518− cachePath = cacheDir </> attr <.> "out"
519 latestChange <- liftIO $ do
677 latestChange <- liftIO $ do
520− createDirectoryIfMissing False cacheDir
678+ let
521− let getModificationTimeMaybe = fmap rightToMaybe . try @IOError . getModificationTime
679+ getModificationTimeMaybe = fmap rightToMaybe . try @IOError . getModificationTime
522− maximum . catMaybes <$> mapM (getModificationTimeMaybe . (thunkDir </>)) thunkFileNames
680+ thunkFileNames = Map.keys $ _thunkSpec_files thunkSpec
523− cacheHit <- handle cacheErrHandler $ do
681+ maximum . catMaybes <$> traverse (getModificationTimeMaybe . (thunkDir </>)) thunkFileNames
524− cacheTime <- liftIO $ posixSecondsToUTCTime . realToFrac . modificationTime <$> getSymbolicLinkStatus cachePath
682+
525− return $ if latestChange <= cacheTime
683+ let cachePaths' = nonEmpty $ Map.keys $ Map.filter (\case ThunkFileSpec_AttrCache -> True; _ -> False) $
526− then Just cachePath
684+ _thunkSpec_files thunkSpec
527− else Nothing
685+ for cachePaths' $ \cachePaths ->
528− case cacheHit of
686+ fmap NonEmpty.head $ for cachePaths $ \cacheDir -> do
529− Just c -> return c
687+ let
530− Nothing -> do
688+ cachePath = thunkDir </> cacheDir </> attr <.> "out"
531− putLog Warning $ T.pack $ mconcat [thunkDir, ": ", attr, " not cached, building ..."]
689+ cacheErrHandler e
532− _ <- nixBuild $ def
690+ | isDoesNotExistError e = pure Nothing -- expected from a cache miss
533− { _nixBuildConfig_target = Target
691+ | otherwise = Nothing <$ putLog Error (T.pack $ displayException e)
534− { _target_path = thunkDir
692+ cacheHit <- handle cacheErrHandler $ do
535− , _target_attr = Just attr
693+ cacheTime <- liftIO $ posixSecondsToUTCTime . realToFrac . modificationTime <$> getSymbolicLinkStatus cachePath
536− }
694+ pure $ if latestChange <= cacheTime
537− , _nixBuildConfig_outLink = OutLink_IndirectRoot cachePath
695+ then Just cachePath
539− return cachePath
697+ case cacheHit of
700+ putLog Warning $ T.pack $ mconcat [thunkDir, ": ", attr, " not cached, building ..."]
701+ liftIO $ createDirectoryIfMissing True (takeDirectory cachePath)
702+ (cachePath <$) $ nixCmd $ NixCmd_Build $ def
703+ & nixBuildConfig_outLink .~ OutLink_IndirectRoot cachePath
704+ & nixCmdConfig_target .~ Target
705+ { _target_path = Just thunkDir
706+ , _target_attr = Just attr
707+ , _target_expr = Nothing
541-- | Build a nix attribute, and cache the result if possible
710-- | Build a nix attribute, and cache the result if possible
542nixBuildAttrWithCache
711nixBuildAttrWithCache
@@ -547,17 +716,19 @@ nixBuildAttrWithCache
547 -- ^ Attribute to build
716 -- ^ Attribute to build
548 -> m FilePath
717 -> m FilePath
549 -- ^ Symlink to cached or built nix output
718 -- ^ Symlink to cached or built nix output
550−nixBuildAttrWithCache exprPath attr = do
719+nixBuildAttrWithCache exprPath attr = readThunk exprPath >>= \case
551− readThunk exprPath >>= \case
720+ -- Only packed thunks are cached. In particular, checkouts are not.
552− -- Only packed thunks are cached. in particular, checkouts are not
721+ Right (ThunkData_Packed spec _) ->
553− Right (ThunkData_Packed _) -> nixBuildThunkAttrWithCache exprPath attr
722+ maybe build pure =<< nixBuildThunkAttrWithCache spec exprPath attr
554− _ -> nixBuild $ def
723+ _ -> build
555− { _nixBuildConfig_target = Target
724+ where
556− { _target_path = exprPath
725+ build = nixCmd $ NixCmd_Build $ def
726+ & nixBuildConfig_outLink .~ OutLink_None
727+ & nixCmdConfig_target .~ Target
728+ { _target_path = Just exprPath
557 , _target_attr = Just attr
729 , _target_attr = Just attr
730+ , _target_expr = Nothing
559− , _nixBuildConfig_outLink = OutLink_None
562-- | Safely update thunk using a custom action
733-- | Safely update thunk using a custom action
@@ -569,241 +740,414 @@ updateThunk p f = withSystemTempDirectory "obelisk-thunkptr-" $ \tmpDir -> do
569 p' <- copyThunkToTmp tmpDir p
740 p' <- copyThunkToTmp tmpDir p
570 unpackThunk' True p'
741 unpackThunk' True p'
571 result <- f p'
742 result <- f p'
572− updateThunkFromTmp p' "origin" -- TODO: stop hardcoding remote
743+ updateThunkFromTmp p'
573 return result
744 return result
575 copyThunkToTmp tmpDir thunkDir = readThunk thunkDir >>= \case
746 copyThunkToTmp tmpDir thunkDir = readThunk thunkDir >>= \case
576 Left err -> failWith $ "withThunkUnpacked: " <> T.pack (show err)
747 Left err -> failWith $ "withThunkUnpacked: " <> T.pack (show err)
577− Right (ThunkData_Packed _) -> do
748+ Right ThunkData_Packed{} -> do
578 let tmpThunk = tmpDir </> "thunk"
749 let tmpThunk = tmpDir </> "thunk"
579 callProcessAndLogOutput (Notice, Error) $
750 callProcessAndLogOutput (Notice, Error) $
580− proc "cp" ["-r", "-T", thunkDir, tmpThunk]
751+ proc cp ["-r", "-T", thunkDir, tmpThunk]
581 return tmpThunk
752 return tmpThunk
582− Right _ -> failWith $ "Thunk is not packed"
753+ Right _ -> failWith "Thunk is not packed"
583− updateThunkFromTmp p' remote = do
754+ updateThunkFromTmp p' = do
584− packThunk' True p' remote
755+ _ <- packThunk' True (ThunkPackConfig False (ThunkConfig Nothing)) p'
585 callProcessAndLogOutput (Notice, Error) $
756 callProcessAndLogOutput (Notice, Error) $
586− proc "cp" ["-r", "-T", p', p]
757+ proc cp ["-r", "-T", p', p]
588finalMsg :: Bool -> (a -> Text) -> Maybe (a -> Text)
759finalMsg :: Bool -> (a -> Text) -> Maybe (a -> Text)
589finalMsg noTrail s = if noTrail then Nothing else Just s
760finalMsg noTrail s = if noTrail then Nothing else Just s
762+-- | Check that we are not somewhere inside the thunk directory
763+checkThunkDirectory :: MonadObelisk m => FilePath -> m ()
764+checkThunkDirectory thunkDir = do
765+ currentDir <- liftIO getCurrentDirectory
766+ thunkDir' <- liftIO $ canonicalizePath thunkDir
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|]
591unpackThunk :: MonadObelisk m => FilePath -> m ()
776unpackThunk :: MonadObelisk m => FilePath -> m ()
592unpackThunk = unpackThunk' False
777unpackThunk = unpackThunk' False
594unpackThunk' :: MonadObelisk m => Bool -> FilePath -> m ()
779unpackThunk' :: MonadObelisk m => Bool -> FilePath -> m ()
595−unpackThunk' noTrail thunkDir = readThunk thunkDir >>= \case
780+unpackThunk' noTrail thunkDir = checkThunkDirectory thunkDir *> readThunk thunkDir >>= \case
596− Left err -> failWith $ "thunk unpack: " <> T.pack (show err)
781+ Left err -> failWith [i|Invalid thunk at ${thunkDir}: ${err}|]
597 --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
598− Right (ThunkData_Checkout _) -> failWith "thunk unpack: thunk is already unpacked"
783+ Right ThunkData_Checkout -> failWith [i|Thunk at ${thunkDir} is already unpacked|]
599− Right (ThunkData_Packed tptr) -> do
784+ Right (ThunkData_Packed _ tptr) -> do
600 let (thunkParent, thunkName) = splitFileName thunkDir
785 let (thunkParent, thunkName) = splitFileName thunkDir
601− withTempDirectory thunkParent thunkName $ \tmpRepo -> do
786+ withTempDirectory thunkParent thunkName $ \tmpThunk -> do
602− let obGitDir = tmpRepo </> ".git" </> "obelisk"
787+ let
603− case _thunkPtr_source tptr of
788+ gitSrc = thunkSourceToGitSource $ _thunkPtr_source tptr
604− ThunkSource_GitHub s -> do
789+ newSpec = case _thunkPtr_source tptr of
605− mauth <- liftIO $ getHubAuth "github.com"
790+ ThunkSource_GitHub _ -> NonEmpty.head gitHubThunkSpecs
606− repoResult <- liftIO $ executeRequestMaybe mauth $ repositoryR (_gitHubSource_owner s) (_gitHubSource_repo s)
791+ ThunkSource_Git _ -> NonEmpty.head gitThunkSpecs
607− githubURI <- either (liftIO . throwIO) (return . repoSshUrl) repoResult >>= \case
792+ withSpinner' ("Fetching thunk " <> T.pack thunkName)
608− Nothing -> failWith "Cannot determine clone URI for thunk source"
793+ (finalMsg noTrail $ const $ "Fetched thunk " <> T.pack thunkName) $ do
609− Just c -> return $ T.unpack $ getUrl c
794+ let unpackedPath = tmpThunk </> unpackedDirName
610−
795+ gitCloneForThunkUnpack gitSrc (_thunkRev_commit $ _thunkPtr_rev tptr) unpackedPath
611− withSpinner' ("Fetching thunk " <> T.pack thunkDir)
796+
612− ( finalMsg noTrail $ const $ "Fetched thunk " <> T.pack thunkDir) $ do
797+ let normalizeMore = dropTrailingPathSeparator . normalise
613− callProcessAndLogOutput (Debug, Debug) $
798+ when (normalizeMore unpackedPath /= normalizeMore tmpThunk) $ -- Only write meta data if the checkout is not inplace
614− proc "hub" ["clone", "-n", githubURI, tmpRepo]
799+ createThunk tmpThunk $ Left newSpec
615− --If this directory already exists then something is weird and we should fail
800+
616− liftIO $ createDirectory obGitDir
801+ liftIO $ do
617− callProcessAndLogOutput (Debug, Error) $
802+ removePathForcibly thunkDir
618− proc "cp" ["-r", "-T", thunkDir </> ".", obGitDir </> "orig-thunk"]
803+ renameDirectory tmpThunk thunkDir
620− -- Checkout
805+gitCloneForThunkUnpack
621− putLog Debug $ "Checking out " <> T.pack (show $ maybe "" untagName $ _gitHubSource_branch s)
806+ :: MonadObelisk m
622− callProcessAndLogOutput (Debug, Debug) $
807+ => GitSource -- ^ Git source to use
623− proc "hub" $ concat
808+ -> Ref hash -- ^ Commit hash to reset to
624− [ ["-C", tmpRepo]
809+ -> FilePath -- ^ Directory to clone into
625− , pure "checkout"
810+ -> m ()
626− , maybe [] (\n -> ["-B", T.unpack (untagName n)]) (_gitHubSource_branch s)
811+gitCloneForThunkUnpack gitSrc commit dir = do
627− , pure $ Ref.toHexString $ _thunkRev_commit $ _thunkPtr_rev tptr
812+ let git = callProcessAndLogOutput (Notice, Notice) . gitProc dir
628− ]
813+ git $ [ "clone" ]
629− -- Set upstream branch
814+ ++ ["--recursive" | _gitSource_fetchSubmodules gitSrc]
630− forM_ (_gitHubSource_branch s) $ \branch ->
815+ ++ [ T.unpack $ gitUriToText $ _gitSource_url gitSrc ]
631− callProcessAndLogOutput (Debug, Error) $
816+ ++ do branch <- maybeToList $ _gitSource_branch gitSrc
632− proc "hub" ["-C", tmpRepo, "branch", "-u", "origin/" <> T.unpack (untagName branch)]
817+ [ "--branch", T.unpack $ untagName branch ]
633− callProcessAndLogOutput (Notice, Error) $ proc "rm" ["-r", thunkDir]
818+ git ["reset", "--hard", Ref.toHexString commit]
634− callProcessAndLogOutput (Notice, Error) $ proc "mv" ["-T", tmpRepo, thunkDir]
819+ when (_gitSource_fetchSubmodules gitSrc) $
635−
820+ git ["submodule", "update", "--recursive", "--init"]
636− ThunkSource_Git s -> do
821+
637− withSpinner' ("Fetching thunk " <> T.pack thunkName)
638− (finalMsg noTrail $ const $ "Fetched thunk " <> T.pack thunkName) $ do
639− let git = callProcessAndLogOutput (Notice, Notice) . gitProc tmpRepo
640− git ["clone", if _gitSource_fetchSubmodules s then "--recursive" else "", show (_gitSource_url s)]
641− git ["reset", "--hard", Ref.toHexString $ _thunkRev_commit $ _thunkPtr_rev tptr]
642− when (_gitSource_fetchSubmodules s) $
643− git ["submodule", "update", "--recursive", "--init"]
644− case _gitSource_branch s of
645− Just b -> git ["branch", "-u", "origin/" <> T.unpack (untagName $ b)]
648− liftIO $ createDirectory obGitDir
649− callProcessAndLogOutput (Notice, Error) $
650− proc "cp" ["-r", "-T", thunkDir </> ".", obGitDir </> "orig-thunk"]
651− callProcessAndLogOutput (Notice, Error) $
652− proc "rm" ["-r", thunkDir]
653− callProcessAndLogOutput (Notice, Error) $
654− proc "mv" ["-T", tmpRepo, thunkDir]
656−--TODO: add force mode to pack even if changes are present
657--TODO: add a rollback mode to pack to the original thunk
822--TODO: add a rollback mode to pack to the original thunk
658−packThunk :: MonadObelisk m => FilePath -> Text -> m ()
823+packThunk :: MonadObelisk m => ThunkPackConfig -> FilePath -> m ThunkPtr
659packThunk = packThunk' False
824packThunk = packThunk' False
661−packThunk' :: MonadObelisk m => Bool -> FilePath -> Text -> m ()
826+packThunk' :: MonadObelisk m => Bool -> ThunkPackConfig -> FilePath -> m ThunkPtr
662−packThunk' noTrail thunkDir upstream = readThunk thunkDir >>= \case
827+packThunk' noTrail (ThunkPackConfig force thunkConfig) thunkDir = checkThunkDirectory thunkDir *> readThunk thunkDir >>= \case
663− Left err -> failWith $ T.pack $ "thunk pack: " <> show err
828+ Right ThunkData_Packed{} -> failWith [i|Thunk at ${thunkDir} is is already packed|]
664− Right (ThunkData_Packed _) -> failWith "pack: thunk is already packed"
829+ _ -> withSpinner'
665− Right (ThunkData_Checkout _) -> do
830+ ("Packing thunk " <> T.pack thunkDir)
666− withSpinner' ("Packing thunk " <> T.pack thunkDir)
831+ (finalMsg noTrail $ const $ "Packed thunk " <> T.pack thunkDir) $
667− (finalMsg noTrail $ const $ "Packed thunk " <> T.pack thunkDir) $ do
832+ do
668− thunkPtr <- getThunkPtr thunkDir upstream
833+ let checkClean = if force then CheckClean_NoCheck else CheckClean_FullCheck
669− callProcessAndLogOutput (Debug, Error) $ proc "rm" ["-rf", thunkDir]
834+ thunkPtr <- modifyThunkPtrByConfig thunkConfig <$> getThunkPtr checkClean thunkDir (_thunkConfig_private thunkConfig)
670− liftIO $ createThunk thunkDir thunkPtr
835+ liftIO $ removePathForcibly thunkDir
671−
836+ createThunk thunkDir $ Right thunkPtr
672−getThunkPtr :: MonadObelisk m => FilePath -> Text -> m ThunkPtr
837+ pure thunkPtr
673−getThunkPtr = getThunkPtr' True
838+
674−
839+modifyThunkPtrByConfig :: ThunkConfig -> ThunkPtr -> ThunkPtr
675−getThunkPtr' :: MonadObelisk m => Bool -> FilePath -> Text -> m ThunkPtr
840+modifyThunkPtrByConfig (ThunkConfig markPrivate') ptr = case markPrivate' of
676−getThunkPtr' checkClean thunkDir upstream = do
841+ Nothing -> ptr
677− when checkClean $ ensureCleanGitRepo thunkDir True $
842+ Just markPrivate -> ptr { _thunkPtr_source = case _thunkPtr_source ptr of
678− "thunk pack: thunk checkout contains unsaved modifications"
843+ ThunkSource_Git s -> ThunkSource_Git $ s { _gitSource_private = markPrivate }
679−
844+ ThunkSource_GitHub s -> ThunkSource_GitHub $ s { _gitHubSource_private = markPrivate }
680− -- Check whether there are any stashes
845+ }
848+ = CheckClean_FullCheck
849+ -- ^ Check that the repo is clean, including .gitignored files
850+ | CheckClean_NotIgnored
851+ -- ^ Check that the repo is clean, not including .gitignored files
852+ | CheckClean_NoCheck
853+ -- ^ Don't check that the repo is clean
855+getThunkPtr :: forall m. MonadObelisk m => CheckClean -> FilePath -> Maybe Bool -> m ThunkPtr
856+getThunkPtr gitCheckClean dir mPrivate = do
857+ let repoLocations = nubOrd $ map (first normalise)
858+ [(".git", "."), (unpackedDirName </> ".git", unpackedDirName)]
859+ repoLocation' <- liftIO $ flip findM repoLocations $ doesDirectoryExist . (dir </>) . fst
860+ thunkDir <- case repoLocation' of
861+ Nothing -> failWith [i|Can't find an unpacked thunk in ${dir}|]
862+ Just (_, path) -> pure $ normalise $ dir </> path
864+ let (checkClean, checkIgnored) = case gitCheckClean of
865+ CheckClean_FullCheck -> (True, True)
866+ CheckClean_NotIgnored -> (True, False)
867+ CheckClean_NoCheck -> (False, False)
868+ when checkClean $ ensureCleanGitRepo thunkDir checkIgnored
869+ "thunk pack: thunk checkout contains unsaved modifications"
871+ -- Check whether there are any stashes
872+ when checkClean $ do
681 stashOutput <- readGitProcess thunkDir ["stash", "list"]
873 stashOutput <- readGitProcess thunkDir ["stash", "list"]
682− when checkClean $ case T.null stashOutput of
874+ unless (T.null stashOutput) $
683− False -> do
875+ failWith $ T.unlines $
684− failWith $ T.unlines $
876+ [ "thunk pack: thunk checkout has stashes"
685− [ "thunk pack: thunk checkout has stashes"
877+ , "git stash list:"
686− , "git stash list:"
878+ ] ++ T.lines stashOutput
687− ] ++ T.lines stashOutput
879+
688− True -> return ()
880+ -- Get current branch
689−
881+ (mCurrentBranch, mCurrentCommit) <- do
690− --Check whether all local heads are pushed
882+ b <- listToMaybe . T.lines <$> readGitProcess thunkDir ["rev-parse", "--abbrev-ref", "HEAD"]
691− repoHeads <- T.lines <$> readGitProcess thunkDir ["for-each-ref", "--format=%(refname:short)", "refs/heads/"]
883+ c <- listToMaybe . T.lines <$> readGitProcess thunkDir ["rev-parse", "HEAD"]
692− remotes <- T.lines <$> readGitProcess thunkDir ["remote"]
884+ case b of
693− --Check that the upstream specified actually exists
885+ (Just "HEAD") -> failWith $ T.unlines
694− case L.find (== upstream) remotes of
886+ [ "thunk pack: You are in 'detached HEAD' state."
695− Nothing -> failWith $ "thunk pack: upstream " <> upstream <> " does not exist. Available upstreams are " <> T.intercalate ", " remotes
887+ , "If you want to pack at the current ref \
696− Just _ -> return ()
888+ \then please create a new branch with 'git checkout -b <new-branch-name>' and push this upstream."
697− -- iterate over cartesian product
889+ ]
698− when checkClean $ forM_ repoHeads $ \hd -> do
890+ _ -> return (b, c)
699− [localRev] <- T.lines <$> readGitProcess thunkDir ["rev-parse", T.unpack hd]
891+
700− forM_ remotes $ \rm -> do
892+ -- Get information on all branches and their (optional) designated upstream
701− --TODO: The error you get if a branch isn't pushed anywhere could be made more user friendly
893+ -- correspondents
702− [remoteMergeRev] <- fmap T.lines $ readGitProcess thunkDir
894+ headDump :: [Text] <- T.lines <$> readGitProcess thunkDir
703− ["merge-base", T.unpack localRev, "remotes/" <> T.unpack rm <> "/" <> T.unpack hd]
895+ [ "for-each-ref"
704− case remoteMergeRev == localRev of
896+ , "--format=%(refname:short) %(upstream:short) %(upstream:remotename)"
705− False -> failWith $ mconcat [ "thunk unpack: branch ", hd, " has not been pushed to ", rm ]
897+ , "refs/heads/"
706− True -> return ()
898+ ]
708− --We assume it's safe to pack the thunk at this point
900+ (headInfo :: Map Text (Maybe (Text, Text)))
709− [remoteUri'] <- fmap T.lines $ readGitProcess thunkDir ["config", "--get", "remote." <> T.unpack upstream <> ".url"]
901+ <- fmap Map.fromList $ forM headDump $ \line -> do
710−
902+ (branch : restOfLine) <- pure $ T.words line
711− let uriParseFailure = "Could not identify git remote: " <> remoteUri'
903+ mUpstream <- case restOfLine of
712− mRemoteUri = parseGitUri remoteUri'
904+ [] -> pure Nothing
713− case mRemoteUri of
905+ [u, r] -> pure $ Just (u, r)
714− Nothing -> failWith uriParseFailure
906+ (_:_) -> failWith "git for-each-ref invalid output"
715− Just remoteUri -> do
907+ pure (branch, mUpstream)
716− refs <- fmap (map (refsToTuples . T.words) . T.lines) $ readGitProcess thunkDir ["show-ref", "--head"]
908+
717− -- safe because exactly one hash is associated with HEAD
909+ putLog Debug $ "branches: " <> T.pack (show headInfo)
718− let Just currentHead = fst <$> L.find ((== "HEAD") . snd) refs
910+
719− remoteHeads = Map.fromList $ catMaybes $ fmap
911+ let errorMap :: Map Text ()
720− (\(x,y) -> (,) x <$> T.stripPrefix ("refs/remotes/" <> upstream <> "/") y)
912+ headUpstream :: Map Text (Text, Text)
721− refs
913+ (errorMap, headUpstream) = flip Map.mapEither headInfo $ \case
722− localHeads = Map.fromList $ catMaybes $ fmap
914+ Nothing -> Left ()
723− (\(x,y) -> (,) x <$> T.stripPrefix "refs/heads/" y)
915+ Just b -> Right b
725− mCurrentUpstreamBranch = Map.lookup currentHead remoteHeads
917+ putLog Debug $ "branches with upstream branch set: " <> T.pack (show headUpstream)
726− <|> Map.lookup currentHead localHeads
918+
727− f <- case isGithubThunk remoteUri of
919+ -- Check that every branch has a remote equivalent
728− Just (owner, repo) -> githubThunkPtr owner repo currentHead
920+ when checkClean $ do
729− Nothing -> gitThunkPtr remoteUri currentHead
921+ let untrackedBranches = Map.keys errorMap
730− pure $ f mCurrentUpstreamBranch
922+ when (not $ L.null untrackedBranches) $ failWith $ T.unlines $
731− where
923+ [ "thunk pack: Certain branches in the thunk have no upstream branch \
732− refsToTuples [x, y] = (x, y)
924+ \set. This means we don't know to check whether all your work is \
733− refsToTuples x = error $ "thunk pack: cannot parse ref " <> show x
925+ \saved. The offending branches are:"
735−-- Just comes with "proof" with the decomposed URL.x
927+ , T.unwords untrackedBranches
736−isGithubThunk :: URI -> Maybe (String, String)
928+ , ""
737−isGithubThunk u
929+ , "To fix this, you probably want to do:"
738− | Just uriAuth <- uriAuthority u
930+ , ""
739− , case uriScheme u of
931+ ] ++
740− "ssh:" -> uriAuth == URIAuth "git@" "github.com" ""
932+ ((\branch -> "git push -u origin " <> branch) <$> untrackedBranches) ++
741− s -> s `L.elem` [ "git:", "https:", "http:" ] -- "http:" just redirects to "https:"
933+ [ ""
742− && uriRegName uriAuth == "github.com"
934+ , "These will push the branches to the default remote under the same \
743− , ["/", owner', repo'] <- splitDirectories (uriPath u)
935+ \name, and (thanks to the `-u`) remember that choice so you don't \
744− = Just (owner', repo')
936+ \get this error again."
745− | otherwise = Nothing
937+ ]
939+ -- loosely by https://stackoverflow.com/questions/7773939/show-git-ahead-and-behind-info-for-all-branches-including-remotes
940+ stats <- ifor headUpstream $ \branch (upstream, _remote) -> do
941+ (stat :: [Text]) <- T.lines <$> readGitProcess thunkDir
942+ [ "rev-list", "--left-right"
943+ , T.unpack branch <> "..." <> T.unpack upstream
945+ let ahead = length $ [ () | Just ('<', _) <- T.uncons <$> stat ]
946+ behind = length $ [ () | Just ('>', _) <- T.uncons <$> stat ]
947+ pure (upstream, (ahead, behind))
949+ -- Those branches which have commits ahead of, i.e. not on, the upstream
950+ -- branch. Purely being behind is fine.
951+ let nonGood = Map.filter ((/= 0) . fst . snd) stats
953+ when (not $ Map.null nonGood) $ failWith $ T.unlines $
954+ [ "thunk pack: Certain branches in the thunk have commits not yet pushed upstream:"
957+ flip map (Map.toList nonGood) (\(branch, (upstream, (ahead, behind))) -> mconcat
958+ [" ", branch, " ahead: ", T.pack (show ahead), " behind: ", T.pack (show behind), " remote branch ", upstream]) ++
960+ , "Please push these upstream and try again. (Or just fetch, if they are somehow \
961+ \pushed but this repo's remote tracking branches don't know it.)"
964+ when checkClean $ do
965+ -- We assume it's safe to pack the thunk at this point
966+ putLog Informational "All changes safe in git remotes. OK to pack thunk."
968+ let remote = maybe "origin" snd $ flip Map.lookup headUpstream =<< mCurrentBranch
970+ [remoteUri'] <- fmap T.lines $ readGitProcess thunkDir
973+ , "remote." <> T.unpack remote <> ".url"
976+ remoteUri <- case parseGitUri remoteUri' of
977+ Nothing -> failWith $ "Could not identify git remote: " <> remoteUri'
978+ Just uri -> pure uri
979+ uriThunkPtr remoteUri mPrivate mCurrentBranch mCurrentCommit
981+-- | Get the latest revision available from the given source
982+getLatestRev :: MonadObelisk m => ThunkSource -> m ThunkRev
984+ let gitS = thunkSourceToGitSource os
985+ (_, commit) <- gitGetCommitBranch (_gitSource_url gitS) (untagName <$> _gitSource_branch gitS)
987+ ThunkSource_GitHub s -> githubThunkRev s commit
988+ ThunkSource_Git s -> gitThunkRev s commit
990+-- | Convert a URI to a thunk
992+-- If the URL is a github URL, we try to just download an archive for
993+-- performance. If that doesn't work (e.g. authentication issue), we fall back
994+-- on just doing things the normal way for git repos in general, and save it as
995+-- a regular git thunk.
996+uriThunkPtr :: MonadObelisk m => GitUri -> Maybe Bool -> Maybe Text -> Maybe Text -> m ThunkPtr
997+uriThunkPtr uri mPrivate mbranch mcommit = do
998+ commit <- case mcommit of
999+ Nothing -> gitGetCommitBranch uri mbranch >>= return . snd
1000+ (Just c) -> return c
1001+ (src, rev) <- uriToThunkSource uri mPrivate mbranch >>= \case
1002+ ThunkSource_GitHub s -> do
1003+ rev <- runExceptT $ githubThunkRev s commit
1005+ Right r -> pure (ThunkSource_GitHub s, r)
1008+\Failed to fetch archive from GitHub. This is probably a private repo. \
1009+\Falling back on normal fetchgit. Original failure:"
1011+ let s' = forgetGithub True s
1012+ (,) (ThunkSource_Git s') <$> gitThunkRev s' commit
1013+ ThunkSource_Git s -> (,) (ThunkSource_Git s) <$> gitThunkRev s commit
1015+ { _thunkPtr_rev = rev
1016+ , _thunkPtr_source = src
1019+-- | N.B. Cannot infer all fields.
1021+-- If the thunk is a GitHub thunk and fails, we do *not* fall back like with
1022+-- `uriThunkPtr`. Unlike a plain URL, a thunk src explicitly states which method
1023+-- should be employed, and so we respect that.
1024+uriToThunkSource :: MonadObelisk m => GitUri -> Maybe Bool -> Maybe Text -> m ThunkSource
1025+uriToThunkSource (GitUri u) mPrivate
1026+ | Right uriAuth <- URI.uriAuthority u
1027+ , Just scheme <- URI.unRText <$> URI.uriScheme u
1029+ "ssh" -> uriAuth == URI.Authority
1030+ { URI.authUserInfo = Just $ URI.UserInfo (fromRight' $ URI.mkUsername "git") Nothing
1031+ , URI.authHost = fromRight' $ URI.mkHost "github.com"
1032+ , URI.authPort = Nothing
1034+ s -> s `L.elem` [ "git", "https", "http" ] -- "http:" just redirects to "https:"
1035+ && URI.unRText (URI.authHost uriAuth) == "github.com"
1036+ , Just (_, owner :| [repoish]) <- URI.uriPath u
1038+ isPrivate <- getIsPrivate
1039+ pure $ ThunkSource_GitHub $ GitHubSource
1040+ { _gitHubSource_owner = N $ URI.unRText owner
1041+ , _gitHubSource_repo = N $ let
1042+ repoish' = URI.unRText repoish
1043+ in fromMaybe repoish' $ T.stripSuffix ".git" repoish'
1044+ , _gitHubSource_branch = N <$> mbranch
1045+ , _gitHubSource_private = isPrivate
1048+ | otherwise = \mbranch -> do
1049+ isPrivate <- getIsPrivate
1050+ pure $ ThunkSource_Git $ GitSource
1051+ { _gitSource_url = GitUri u
1052+ , _gitSource_branch = N <$> mbranch
1053+ , _gitSource_fetchSubmodules = False -- TODO: How do we determine if this should be true?
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
747-- Funny signature indicates no effects depend on the optional branch name.
1085-- Funny signature indicates no effects depend on the optional branch name.
748−githubThunkPtr
1086+githubThunkRev
749− :: MonadObelisk m
1087+ :: forall m
750− => String
1088+ . MonadObelisk m
751− -> String
1089+ => GitHubSource
753− -> m (Maybe Text -> ThunkPtr)
1091+ -> m ThunkRev
754−githubThunkPtr owner' repo' commit = do
1092+githubThunkRev s commit = do
755− let owner = N (T.pack owner')
1093+ owner <- forcePP $ _gitHubSource_owner s
756− repo = N (T.pack (dropExtension repo'))
1094+ repo <- forcePP $ _gitHubSource_repo s
757− mauth <- liftIO $ getHubAuth "github.com"
1095+ revTarball <- URI.mkPathPiece $ commit <> ".tar.gz"
758− archiveResult <- liftIO $ executeRequestMaybe mauth $
1096+ let archiveUri = GitUri $ URI.URI
759− archiveForR owner repo ArchiveFormatTarball (Just commit)
1097+ { URI.uriScheme = Just $ fromRight' $ URI.mkScheme "https"
760− archiveUri <- either (liftIO . throwIO) return archiveResult
1098+ , URI.uriAuthority = Right $ URI.Authority
1099+ { URI.authUserInfo = Nothing
1100+ , URI.authHost = fromRight' $ URI.mkHost "github.com"
1101+ , URI.authPort = Nothing
1103+ , URI.uriPath = Just ( False
1104+ , owner :| [ repo, fromRight' $ URI.mkPathPiece "archive", revTarball ]
1106+ , URI.uriQuery = []
1107+ , URI.uriFragment = Nothing
761 hash <- getNixSha256ForUriUnpacked archiveUri
1109 hash <- getNixSha256ForUriUnpacked archiveUri
762− return $ \mbranch -> ThunkPtr
1110+ putLog Debug $ "Nix sha256 is " <> hash
763− { _thunkPtr_rev = ThunkRev
1111+ return $ ThunkRev
764− { _thunkRev_commit = commitNameToRef $ N commit
1112+ { _thunkRev_commit = commitNameToRef $ N commit
765− , _thunkRev_nixSha256 = hash
1113+ , _thunkRev_nixSha256 = hash
767− , _thunkPtr_source = ThunkSource_GitHub $ GitHubSource
768− { _gitHubSource_owner = owner
769− , _gitHubSource_repo = repo
770− , _gitHubSource_branch = N <$> mbranch
1116+ forcePP :: Name entity -> m (URI.RText 'URI.PathPiece)
1117+ forcePP = URI.mkPathPiece . untagName
774−gitThunkPtr
1119+gitThunkRev
775 :: MonadObelisk m
1120 :: MonadObelisk m
776− => URI
1121+ => GitSource
778− -> m (Maybe Text -> ThunkPtr)
1123+ -> m ThunkRev
779−gitThunkPtr u commit = do
1124+gitThunkRev s commit = do
780− let protocols = ["https:", "ssh:", "git:"]
1125+ let u = _gitSource_url s
781− unless (T.toLower (T.pack $ uriScheme u) `elem` protocols) $
1126+ protocols = ["file", "https", "ssh", "git"]
782− failWith $ "thunk pack: obelisk currently only supports "
1127+ scheme = maybe "file" URI.unRText $ URI.uriScheme $ (\(GitUri x) -> x) u
783− <> T.intercalate ", " protocols <> " protocols for non-GitHub remotes"
1128+ unless (T.toLower scheme `elem` protocols) $
784− hash <- nixPrefetchGit u commit False
1129+ failWith $ "obelisk currently only supports "
785− pure $ \mbranch -> ThunkPtr
1130+ <> T.intercalate ", " protocols <> " protocols for plain Git remotes"
786− { _thunkPtr_rev = ThunkRev
1131+ hash <- nixPrefetchGit u commit $ _gitSource_fetchSubmodules s
787− { _thunkRev_commit = commitNameToRef (N commit)
1132+ putLog Informational $ "Nix sha256 is " <> hash
788− , _thunkRev_nixSha256 = hash
1133+ pure $ ThunkRev
789− }
1134+ { _thunkRev_commit = commitNameToRef (N commit)
790− , _thunkPtr_source = ThunkSource_Git $ GitSource
1135+ , _thunkRev_nixSha256 = hash
791− { _gitSource_url = u
792− , _gitSource_branch = N <$> mbranch
793− , _gitSource_fetchSubmodules = False -- TODO: How do we determine if this should be true?
797−commitThunkPtr :: MonadObelisk m => URI -> Text -> m (Maybe Text -> ThunkPtr)
1138+-- | Given the URI to a git remote, and an optional branch name, return the name
798−commitThunkPtr uri commit = do
1139+-- of the branch along with the hash of the commit at tip of that branch.
799− case isGithubThunk uri of
1140+--
800− Just (owner, repo) -> githubThunkPtr owner repo commit
1141+-- If the branch name is passed in, it is returned exactly as-is. If it is not
801− Nothing -> gitThunkPtr uri commit
1142+-- passed it, the default branch of the repo is used instead.
803gitGetCommitBranch
1144gitGetCommitBranch
804− :: MonadObelisk m => URI -> Maybe Text -> m (Text, Text)
1145+ :: MonadObelisk m => GitUri -> Maybe Text -> m (Text, CommitId)
805gitGetCommitBranch uri mbranch = withExitFailMessage ("Failure for git remote " <> uriMsg) $ do
1146gitGetCommitBranch uri mbranch = withExitFailMessage ("Failure for git remote " <> uriMsg) $ do
806− bothMaps <- rethrowE =<< liftIO (gitLsRemote (show uri) (GitRef_Branch <$> mbranch))
1147+ (_, bothMaps) <- gitLsRemote
1148+ (T.unpack $ gitUriToText uri)
1149+ (GitRef_Branch <$> mbranch)
807 branch <- case mbranch of
1151 branch <- case mbranch of
808 Nothing -> withExitFailMessage "Failed to find default branch" $ do
1152 Nothing -> withExitFailMessage "Failed to find default branch" $ do
809 b <- rethrowE $ gitLookupDefaultBranch bothMaps
1153 b <- rethrowE $ gitLookupDefaultBranch bothMaps
@@ -811,23 +1155,27 @@ gitGetCommitBranch uri mbranch = withExitFailMessage ("Failure for git remote "
812 Just b -> pure b
1156 Just b -> pure b
813 commit <- rethrowE $ gitLookupCommitForRef bothMaps (GitRef_Branch branch)
1157 commit <- rethrowE $ gitLookupCommitForRef bothMaps (GitRef_Branch branch)
814− putLog Debug $ "Latest commit in branch " <> branch
1158+ putLog Informational $ "Latest commit in branch " <> branch
815 <> " from remote repo " <> uriMsg
1159 <> " from remote repo " <> uriMsg
816 <> " is " <> commit
1160 <> " is " <> commit
817 pure (branch, commit)
1161 pure (branch, commit)
819 rethrowE = either failWith pure
1163 rethrowE = either failWith pure
820− uriMsg = T.pack $ show uri
1164+ uriMsg = gitUriToText uri
1166+parseGitUri :: Text -> Maybe GitUri
1167+parseGitUri x = GitUri <$> (parseFileURI x <|> parseAbsoluteURI x <|> parseSshShorthand x)
822−uriThunkPtr :: MonadObelisk m => URI -> Maybe Text -> m ThunkPtr
1169+parseFileURI :: Text -> Maybe URI.URI
823−uriThunkPtr uri mbranch = do
1170+parseFileURI uri = if "/" `T.isPrefixOf` uri then parseAbsoluteURI ("file://" <> uri) else Nothing
824− (_, commit) <- gitGetCommitBranch uri mbranch
825− commitThunkPtr uri commit <*> pure mbranch
827−parseGitUri :: Text -> Maybe URI
1172+parseAbsoluteURI :: Text -> Maybe URI.URI
828−parseGitUri x = parseURIReference (T.unpack x) <|> parseSshShorthand x
1173+parseAbsoluteURI uri = do
1174+ parsedUri <- URI.mkURI uri
1175+ guard $ URI.isPathAbsolute parsedUri
830−parseSshShorthand :: Text -> Maybe URI
1178+parseSshShorthand :: Text -> Maybe URI.URI
831parseSshShorthand uri = do
1179parseSshShorthand uri = do
832 -- This is what git does to check that the remote
1180 -- This is what git does to check that the remote
833 -- is not a local file path when parsing shorthand.
1181 -- is not a local file path when parsing shorthand.
@@ -840,4 +1188,4 @@ parseSshShorthand uri = do
840 -- This check is used to disambiguate a filepath containing a colon from shorthand
1188 -- This check is used to disambiguate a filepath containing a colon from shorthand
841 guard $ isNothing (T.findIndex (=='/') authAndHostname)
1189 guard $ isNothing (T.findIndex (=='/') authAndHostname)
842 && not (T.null colonAndPath)
1190 && not (T.null colonAndPath)
843− parseURI $ T.unpack properUri
1191+ URI.mkURI properUri