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