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