@@ -5,82 +5,70 @@
5{-# LANGUAGE MultiWayIf #-}
5{-# LANGUAGE MultiWayIf #-}
6{-# LANGUAGE OverloadedStrings #-}
6{-# LANGUAGE OverloadedStrings #-}
7{-# LANGUAGE PatternGuards #-}
7{-# LANGUAGE PatternGuards #-}
8−{-# LANGUAGE TemplateHaskell #-}
8+{-# LANGUAGE QuasiQuotes #-}
9−
9+{-# LANGUAGE ScopedTypeVariables #-}
10−module Obelisk.Command.Thunk
10+{-# LANGUAGE TypeApplications #-}
11− ( ThunkPtr (..)
11+module Obelisk.Command.Thunk where
15− , ReadThunkError (..)
18− , updateThunkToLatest
20− , createThunkWithLatest
21− , nixBuildAttrWithCache
22− , nixBuildThunkAttrWithCache
29import Control.Applicative
13import Control.Applicative
30−import Control.Exception (displayException, throwIO)
14+import Control.Exception (displayException, try)
15+import Control.Lens (ifor, ifor_, (.~))
31import Control.Monad
16import Control.Monad
32−import Control.Monad.Catch (handle)
17+import Control.Monad.Extra (findM)
18+import Control.Monad.Catch (MonadCatch, handle)
33import Control.Monad.Except
19import Control.Monad.Except
34−import Data.Aeson (decode, (.=))
20+import Data.Aeson ((.=))
35import qualified Data.Aeson as Aeson
21import qualified Data.Aeson as Aeson
36import Data.Aeson.Encode.Pretty
22import Data.Aeson.Encode.Pretty
23+import qualified Data.Aeson.Types as Aeson
24+import Data.Bifunctor (first)
37import qualified Data.ByteString.Lazy as LBS
25import qualified Data.ByteString.Lazy as LBS
26+import Data.Containers.ListUtils (nubOrd)
38import Data.Default
27import Data.Default
39−import Data.Foldable
28+import Data.Either.Combinators (fromRight', rightToMaybe)
29+import Data.Foldable (toList)
30+import Data.Function ((&))
31+import Data.Functor ((<&>))
40import Data.Git.Ref (Ref)
32import Data.Git.Ref (Ref)
41import qualified Data.Git.Ref as Ref
33import qualified Data.Git.Ref as Ref
42import qualified Data.List as L
34import qualified Data.List as L
43−import Data.List.NonEmpty (NonEmpty (..))
35+import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
44import qualified Data.List.NonEmpty as NonEmpty
36import qualified Data.List.NonEmpty as NonEmpty
45import qualified Data.Map as Map
38import qualified Data.Map as Map
46import Data.Maybe
39import Data.Maybe
48import Data.Set (Set)
40import Data.Set (Set)
49import 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)
50import Data.Text (Text)
44import Data.Text (Text)
51import qualified Data.Text as T
45import qualified Data.Text as T
52import Data.Text.Encoding
46import Data.Text.Encoding
53import qualified Data.Text.IO as T
47import qualified Data.Text.IO as T
54import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
48import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
55−import Data.Yaml (parseMaybe, (.:))
49+import Data.Traversable (for)
56−import qualified Data.Yaml as Yaml
50+import Data.Yaml (parseMaybe)
57import GitHub
51import GitHub
58import GitHub.Data.Name
52import GitHub.Data.Name
59−import GitHub.Endpoints.Repos.Contents (archiveForR)
61import Obelisk.Command.Nix
53import Obelisk.Command.Nix
62import System.Directory
54import System.Directory
63import System.Exit
55import System.Exit
64import System.FilePath
56import System.FilePath
66import System.IO.Error
57import System.IO.Error
67import System.IO.Temp
58import System.IO.Temp
68−import System.Posix (getSymbolicLinkStatus, modificationTime)
59+import System.PosixCompat.Files (getSymbolicLinkStatus, modificationTime)
69−import System.Process (StdStream (CreatePipe), callProcess, createProcess, proc, readProcess, std_err,
60+import qualified Text.URI as URI
70− std_out, waitForProcess)
72−import Development.Placeholders
73import Obelisk.App (MonadObelisk)
62import Obelisk.App (MonadObelisk)
74−import Obelisk.CLI (Severity (..), callProcessAndLogOutput, failWith, putLog, withSpinner)
63+import Obelisk.CliApp
75−import Obelisk.Command.Utils (checkGitCleanStatus, cp, procWithPackages)
64+import Obelisk.Command.Utils
77--TODO: Support symlinked thunk data
66--TODO: Support symlinked thunk data
78data ThunkData
67data ThunkData
79− = ThunkData_Packed ThunkPtr
68+ = ThunkData_Packed ThunkSpec ThunkPtr
80 -- ^ Packed thunk
69 -- ^ Packed thunk
81− | ThunkData_Checkout (Maybe ThunkPtr)
70+ | ThunkData_Checkout
82 -- ^ Checked out thunk that was unpacked from this pointer
71 -- ^ Checked out thunk that was unpacked from this pointer
83− deriving (Show, Eq, Ord)
85-- | 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
86data ThunkPtr = ThunkPtr
74data ThunkPtr = ThunkPtr
@@ -93,7 +81,7 @@ type NixSha256 = Text --TODO: Use a smart constructor and make this actually ver
94-- | 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
95data ThunkRev = ThunkRev
83data ThunkRev = ThunkRev
96− { _thunkRev_commit :: Ref
84+ { _thunkRev_commit :: Ref Ref.SHA1
97 , _thunkRev_nixSha256 :: NixSha256
85 , _thunkRev_nixSha256 :: NixSha256
99 deriving (Show, Eq, Ord)
87 deriving (Show, Eq, Ord)
@@ -106,6 +94,11 @@ data ThunkSource
106 | ThunkSource_Git GitSource
94 | ThunkSource_Git GitSource
107 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
109data GitHubSource = GitHubSource
102data GitHubSource = GitHubSource
110 { _gitHubSource_owner :: Name Owner
103 { _gitHubSource_owner :: Name Owner
111 , _gitHubSource_repo :: Name Repo
104 , _gitHubSource_repo :: Name Repo
@@ -114,158 +107,263 @@ data GitHubSource = GitHubSource
115 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
117data GitSource = GitSource
119data GitSource = GitSource
118− { _gitSource_url :: URI
120+ { _gitSource_url :: GitUri
119− --TODO: Is it ok to use the types from the GitHub api bindings?
120 , _gitSource_branch :: Maybe (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)
125−commitNameToRef :: Name Commit -> Ref
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
165+getThunkGitBranch :: ThunkPtr -> Maybe Text
166+getThunkGitBranch (ThunkPtr _ src) = fmap untagName $ case src of
167+ ThunkSource_GitHub s -> _gitHubSource_branch s
168+ ThunkSource_Git s -> _gitSource_branch s
170+commitNameToRef :: Name Commit -> Ref Ref.SHA1
126commitNameToRef (N c) = Ref.fromHex $ encodeUtf8 c
171commitNameToRef (N c) = Ref.fromHex $ encodeUtf8 c
128-- TODO: Use spinner here.
173-- TODO: Use spinner here.
129−getNixSha256ForUriUnpacked :: URI -> IO NixSha256
174+getNixSha256ForUriUnpacked
130−getNixSha256ForUriUnpacked uri = do
175+ :: MonadObelisk m
131− --TODO: Make this package depend on nix-prefetch-url properly
176+ => GitUri
132− let cmd = proc "nix-prefetch-url" ["--unpack" , "--type" , "sha256" , show uri]
177+ -> m NixSha256
133− (_, Just out, Just err, p) <- createProcess cmd
178+getNixSha256ForUriUnpacked uri =
134− { std_out = CreatePipe
179+ withExitFailMessage ("nix-prefetch-url: Failed to determine sha256 hash of URL " <> gitUriToText uri) $ do
135− , std_err = CreatePipe
180+ [hash] <- fmap T.lines $ readProcessAndLogOutput (Debug, Debug) $
136− }
181+ proc nixPrefetchUrlPath ["--unpack", "--type", "sha256", T.unpack $ gitUriToText uri]
137− --TODO: Deal with errors here; usually they're HTTP errors
182+ pure hash
138− waitForProcess p >>= \case
139− ExitSuccess -> return ()
141− hPutStrLn stdout =<< hGetContents out
142− hPutStrLn stderr =<< hGetContents err
143− --TODO: actual error
144− fail "nix-prefetch-url"
145− T.strip <$> T.hGetContents out
147−-- | Get the latest revision available from the given source
184+nixPrefetchGit :: MonadObelisk m => GitUri -> Text -> Bool -> m NixSha256
148−getLatestRev :: ThunkSource -> IO ThunkRev
185+nixPrefetchGit uri rev fetchSubmodules =
149−getLatestRev = \case
186+ withExitFailMessage ("nix-prefetch-git: Failed to determine sha256 hash of Git repo " <> gitUriToText uri <> " at " <> rev) $ do
150− ThunkSource_GitHub s -> do
187+ out <- readProcessAndLogStderr Debug $
151− auth <- getHubAuth "github.com"
188+ proc nixPrefetchGitPath $ filter (/="")
152− commitsResult <- executeRequestMaybe auth $ commitsWithOptionsForR
189+ [ "--url", T.unpack $ gitUriToText uri
153− (_gitHubSource_owner s)
190+ , "--rev", T.unpack rev
154− (_gitHubSource_repo s)
191+ , if fetchSubmodules then "--fetch-submodules" else ""
155− (FetchAtLeast 1)
192+ , "--quiet"
156− $ case _gitHubSource_branch s of
193+ ]
158− Just b -> [CommitQuerySha $ untagName b]
195+ case parseMaybe (Aeson..: "sha256") =<< Aeson.decodeStrict (encodeUtf8 out) of
159− commitInfos <- either throwIO return commitsResult
196+ Nothing -> failWith $ "nix-prefetch-git: unrecognized output " <> out
160− commitInfo : _ <- return $ toList commitInfos
197+ Just x -> pure x
161− let commit = commitSha commitInfo
162− Right archiveUri <- executeRequestMaybe auth $ archiveForR (_gitHubSource_owner s) (_gitHubSource_repo s) ArchiveFormatTarball $ Just $ untagName commit
163− nixSha256 <- getNixSha256ForUriUnpacked archiveUri
165− { _thunkRev_commit = commitNameToRef commit
166− , _thunkRev_nixSha256 = nixSha256
168− ThunkSource_Git _s -> do
171--TODO: Pretty print these
199--TODO: Pretty print these
172data ReadThunkError
200data ReadThunkError
173− = ReadThunkError_WrongContents (Set String) (Set String)
201+ = ReadThunkError_UnrecognizedThunk
174− | ReadThunkError_UnrecognizedLoader Text
202+ | ReadThunkError_UnrecognizedPaths (NonEmpty FilePath)
175− | ReadThunkError_UnparseablePtr LBS.ByteString
203+ | ReadThunkError_MissingPaths (NonEmpty FilePath)
176− deriving (Show)
204+ | ReadThunkError_UnparseablePtr FilePath String
177−
205+ | ReadThunkError_FileError IOError
178−-- | Read a thunk and validate that it is only a thunk, either packed or unpacked.
206+ | ReadThunkError_FileDoesNotMatch FilePath Text
179−-- If the thunk is packed and additional data is present, fail.
207+ | ReadThunkError_UnrecognizedState String
180−readThunk :: MonadObelisk m => FilePath -> m (Either ReadThunkError ThunkData)
208+ | ReadThunkError_AmbiguousPackedState ThunkPtr ThunkPtr
181−readThunk thunkDir = do
209+ deriving (Show)
182− files <- liftIO $ listDirectory thunkDir
210+
183− case ".git" `elem` files of
211+unpackedDirName :: FilePath
184− True -> fmap ThunkData_Checkout <$> do
212+unpackedDirName = "."
185− let origThunkPath = thunkDir </> ".git" </> "obelisk" </> "orig-thunk"
213+
186− liftIO $ doesDirectoryExist origThunkPath >>= \case
214+attrCacheFileName :: FilePath
187− True -> fmap Just <$> readPackedThunk origThunkPath
215+attrCacheFileName = ".attr-cache"
188− False -> return $ return Nothing
216+
189− False -> liftIO $ fmap ThunkData_Packed <$> readPackedThunk thunkDir
217+-- | Specification for how a file in a thunk version works.
219+ = ThunkFileSpec_Ptr (LBS.ByteString -> Either String ThunkPtr) -- ^ This file specifies 'ThunkPtr' data
220+ | ThunkFileSpec_FileMatches Text -- ^ This file must match the given content exactly
221+ | ThunkFileSpec_CheckoutIndicator -- ^ Existence of this directory indicates that the thunk is unpacked
222+ | ThunkFileSpec_AttrCache -- ^ This directory is an attribute cache
224+-- | Specification for how a set of files in a thunk version work.
225+data ThunkSpec = ThunkSpec
226+ { _thunkSpec_name :: !Text
227+ , _thunkSpec_files :: !(Map FilePath ThunkFileSpec)
230+thunkSpecTypes :: NonEmpty (NonEmpty ThunkSpec)
231+thunkSpecTypes = gitThunkSpecs :| [gitHubThunkSpecs]
233+-- | Attempts to match a 'ThunkSpec' to a given directory.
235+ :: (MonadError ReadThunkError m, MonadIO m, MonadCatch m)
236+ => ThunkSpec -- ^ 'ThunkSpec' to match against the given files/directory
237+ -> FilePath -- ^ Path to directory
238+ -> Set FilePath -- ^ Set of file paths relative to the given directory
240+matchThunkSpecToDir thunkSpec dir dirFiles = do
241+ case nonEmpty (toList $ dirFiles `Set.difference` expectedPaths) of
242+ Just fs -> throwError $ ReadThunkError_UnrecognizedPaths $ (dir </>) <$> fs
244+ case nonEmpty (toList $ requiredPaths `Set.difference` dirFiles) of
245+ Just fs -> throwError $ ReadThunkError_MissingPaths $ (dir </>) <$> fs
247+ datas <- fmap toList $ flip Map.traverseMaybeWithKey (_thunkSpec_files thunkSpec) $ \expectedPath -> \case
248+ ThunkFileSpec_AttrCache -> Nothing <$ dirMayExist expectedPath
249+ ThunkFileSpec_CheckoutIndicator -> liftIO (doesDirectoryExist (dir </> expectedPath)) <&> \case
251+ True -> Just ThunkData_Checkout
252+ ThunkFileSpec_FileMatches expectedContents -> handle (\(e :: IOError) -> throwError $ ReadThunkError_FileError e) $ do
253+ actualContents <- liftIO (T.readFile $ dir </> expectedPath)
254+ case T.strip expectedContents == T.strip actualContents of
255+ True -> pure Nothing
256+ False -> throwError $ ReadThunkError_FileDoesNotMatch (dir </> expectedPath) expectedContents
257+ ThunkFileSpec_Ptr parser -> handle (\(e :: IOError) -> throwError $ ReadThunkError_FileError e) $ do
258+ let path = dir </> expectedPath
259+ liftIO (doesFileExist path) >>= \case
260+ False -> pure Nothing
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}|]
191-- | 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.
192-- If additional data is present, fail.
309-- If additional data is present, fail.
193−readPackedThunk :: FilePath -> IO (Either ReadThunkError ThunkPtr)
310+readThunk :: (MonadObelisk m) => FilePath -> m (Either ReadThunkError ThunkData)
194−readPackedThunk thunkDir = runExceptT $ do
311+readThunk = readThunkWith thunkSpecTypes
195− let thunkLoader = thunkDir </> "default.nix"
196− githubJson = thunkDir </> "github.json"
197− attrCache = thunkDir </> ".attr-cache"
198− expectedContents = Set.fromList $
202− optionalContents = Set.fromList $
206− -- Ensure that there aren't any other files in the thunk
313+parseThunkPtr :: (Aeson.Object -> Aeson.Parser ThunkSource) -> Aeson.Object -> Aeson.Parser ThunkPtr
207− -- NB: System.Directory.listDirectory returns the contents without the directory path
314+parseThunkPtr parseSrc v = do
208− files <- liftIO $ Set.fromList . fmap (thunkDir </>) <$> listDirectory thunkDir
315+ rev <- v Aeson..: "rev"
209− let unexpectedContents = files `Set.difference` (expectedContents `Set.union` optionalContents)
316+ sha256 <- v Aeson..: "sha256"
210− missingContents = expectedContents `Set.difference` files
317+ src <- parseSrc v
211− unless (Set.null unexpectedContents && Set.null missingContents) $ do
318+ pure $ ThunkPtr
212− throwError $ ReadThunkError_WrongContents unexpectedContents missingContents
319+ { _thunkPtr_rev = ThunkRev
213−
320+ { _thunkRev_commit = Ref.fromHexString rev
214− -- Ensure that we recognize the thunk loader
321+ , _thunkRev_nixSha256 = sha256
215− loader <- liftIO $ T.readFile thunkLoader
322+ }
216− unless (loader `elem` gitHubStandaloneLoaders) $ do
323+ , _thunkPtr_source = src
217− throwError $ ReadThunkError_UnrecognizedLoader loader
324+ }
219− txt <- liftIO $ LBS.readFile githubJson
326+parseGitHubSource :: Aeson.Object -> Aeson.Parser GitHubSource
220− let parseThunk v = do
327+parseGitHubSource v = do
221− rev <- v Aeson..: "rev"
328+ owner <- v Aeson..: "owner"
222− sha256 <- v Aeson..: "sha256"
329+ repo <- v Aeson..: "repo"
223− src <- parseGitHubSource v
330+ branch <- v Aeson..:! "branch"
224− <|> parseGitSource v
331+ private <- v Aeson..:? "private"
225− return $ ThunkPtr
332+ pure $ GitHubSource
226− { _thunkPtr_rev = ThunkRev
333+ { _gitHubSource_owner = owner
227− { _thunkRev_commit = Ref.fromHexString rev
334+ , _gitHubSource_repo = repo
228− , _thunkRev_nixSha256 = sha256
335+ , _gitHubSource_branch = branch
229− }
336+ , _gitHubSource_private = fromMaybe False private
230− , _thunkPtr_source = src
337+ }
232− parseGitHubSource v = do
339+parseGitSource :: Aeson.Object -> Aeson.Parser GitSource
233− owner <- v Aeson..: "owner"
340+parseGitSource v = do
234− repo <- v Aeson..: "repo"
341+ Just url <- parseGitUri <$> v Aeson..: "url"
235− branch <- v Aeson..:! "branch"
342+ branch <- v Aeson..:! "branch"
236− mPrivate <- v Aeson..:! "private"
343+ fetchSubmodules <- v Aeson..:! "fetchSubmodules"
237− return $ ThunkSource_GitHub $ GitHubSource
344+ private <- v Aeson..:? "private"
238− { _gitHubSource_owner = owner
345+ pure $ GitSource
239− , _gitHubSource_repo = repo
346+ { _gitSource_url = url
240− , _gitHubSource_branch = branch
347+ , _gitSource_branch = branch
241− , _gitHubSource_private = fromMaybe False mPrivate
348+ , _gitSource_fetchSubmodules = fromMaybe False fetchSubmodules
242− }
349+ , _gitSource_private = fromMaybe False private
243− parseGitSource v = do
350+ }
244− Just url <- parseURI <$> v Aeson..: "url"
245− branch <- v Aeson..:! "branch"
246− fetchSubmodules <- v Aeson..: "fetchSubmodules"
247− return $ ThunkSource_Git $ GitSource
248− { _gitSource_url = url
249− , _gitSource_branch = branch
250− , _gitSource_fetchSubmodules = fetchSubmodules
252− case parseMaybe parseThunk =<< decode txt of
253− Nothing -> throwError $ ReadThunkError_UnparseablePtr txt
254− Just ptr -> return ptr
256overwriteThunk :: MonadObelisk m => FilePath -> ThunkPtr -> m ()
352overwriteThunk :: MonadObelisk m => FilePath -> ThunkPtr -> m ()
257overwriteThunk target thunk = do
353overwriteThunk target thunk = do
258 -- 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)
259− Right _ <- readThunk target
355+ readThunk target >>= \case
356+ Left e -> failWith [i|Invalid thunk at ${target}: ${e}|]
261 --TODO: Is there a safer way to do this overwriting?
359 --TODO: Is there a safer way to do this overwriting?
262− liftIO $ removeDirectoryRecursive target
360+ liftIO $ removePathForcibly target
263− liftIO $ createThunk target thunk
361+ createThunk target $ Right thunk
265−thunkPtrLoader :: ThunkPtr -> Text
363+thunkPtrToSpec :: ThunkPtr -> ThunkSpec
266−thunkPtrLoader thunk = case _thunkPtr_source thunk of
364+thunkPtrToSpec thunk = case _thunkPtr_source thunk of
267− ThunkSource_GitHub _ -> NonEmpty.head gitHubStandaloneLoaders
365+ ThunkSource_GitHub _ -> NonEmpty.head gitHubThunkSpecs
268− ThunkSource_Git _ -> NonEmpty.head plainGitStandaloneLoaders
366+ ThunkSource_Git _ -> NonEmpty.head gitThunkSpecs
270-- It's important that formatting be very consistent here, because
368-- It's important that formatting be very consistent here, because
271-- otherwise when people update thunks, their patches will be messy
369-- otherwise when people update thunks, their patches will be messy
@@ -274,21 +372,18 @@ encodeThunkPtrData (ThunkPtr rev src) = case src of
274 ThunkSource_GitHub s -> encodePretty' githubCfg $ Aeson.object $ catMaybes
372 ThunkSource_GitHub s -> encodePretty' githubCfg $ Aeson.object $ catMaybes
275 [ Just $ "owner" .= _gitHubSource_owner s
373 [ Just $ "owner" .= _gitHubSource_owner s
276 , Just $ "repo" .= _gitHubSource_repo s
374 , Just $ "repo" .= _gitHubSource_repo s
277− , case _gitHubSource_branch s of
375+ , ("branch" .=) <$> _gitHubSource_branch s
278− Just b -> Just $ "branch" .= b
280− , if _gitHubSource_private s
281− then Just $ "private" .= True
283 , Just $ "rev" .= Ref.toHexString (_thunkRev_commit rev)
376 , Just $ "rev" .= Ref.toHexString (_thunkRev_commit rev)
284 , Just $ "sha256" .= _thunkRev_nixSha256 rev
377 , Just $ "sha256" .= _thunkRev_nixSha256 rev
378+ , Just $ "private" .= _gitHubSource_private s
286 ThunkSource_Git s -> encodePretty' plainGitCfg $ Aeson.object $ catMaybes
380 ThunkSource_Git s -> encodePretty' plainGitCfg $ Aeson.object $ catMaybes
287− --TODO: Is this safe? read/show is jank for `URI`
381+ [ Just $ "url" .= gitUriToText (_gitSource_url s)
288− [ Just $ "url" .= show (_gitSource_url s)
289 , Just $ "rev" .= Ref.toHexString (_thunkRev_commit rev)
382 , Just $ "rev" .= Ref.toHexString (_thunkRev_commit rev)
383+ , ("branch" .=) <$> _gitSource_branch s
290 , Just $ "sha256" .= _thunkRev_nixSha256 rev
384 , Just $ "sha256" .= _thunkRev_nixSha256 rev
291 , Just $ "fetchSubmodules" .= _gitSource_fetchSubmodules s
385 , Just $ "fetchSubmodules" .= _gitSource_fetchSubmodules s
386+ , Just $ "private" .= _gitSource_private s
294 githubCfg = defConfig
389 githubCfg = defConfig
@@ -309,55 +404,84 @@ encodeThunkPtrData (ThunkPtr rev src) = case src of
311 , "sha256"
406 , "sha256"
312 , "fetchSubmodules"
408 , "fetchSubmodules"
313 ] <> compare
409 ] <> compare
314 , confTrailingNewline = True
410 , confTrailingNewline = True
317−createThunk :: FilePath -> ThunkPtr -> IO ()
413+createThunk :: MonadObelisk m => FilePath -> Either ThunkSpec ThunkPtr -> m ()
318−createThunk target thunk = do
414+createThunk target ptrInfo =
319− createDirectoryIfMissing True (target </> ".attr-cache")
415+ ifor_ (_thunkSpec_files spec) $ \path -> \case
320− T.writeFile (target </> "default.nix") (thunkPtrLoader thunk)
416+ ThunkFileSpec_FileMatches content -> withReadyPath path $ \p -> liftIO $ T.writeFile p content
321− LBS.writeFile (target </> "github.json") (encodeThunkPtrData thunk)
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
323−createThunkWithLatest :: FilePath -> ThunkSource -> IO ()
429+createThunkWithLatest :: MonadObelisk m => FilePath -> ThunkSource -> m ()
324createThunkWithLatest target s = do
430createThunkWithLatest target s = do
325 rev <- getLatestRev s
431 rev <- getLatestRev s
326− createThunk target $ ThunkPtr
432+ createThunk target $ Right $ ThunkPtr
327 { _thunkPtr_source = s
433 { _thunkPtr_source = s
328 , _thunkPtr_rev = rev
434 , _thunkPtr_rev = rev
331−updateThunkToLatest :: MonadObelisk m => FilePath -> m ()
437+updateThunkToLatest :: MonadObelisk m => ThunkUpdateConfig -> FilePath -> m ()
332−updateThunkToLatest target = do
438+updateThunkToLatest (ThunkUpdateConfig mBranch thunkConfig) target = spinner $ do
333− (overwrite, ptr) <- readThunk target >>= \case
439+ checkThunkDirectory target
334− Left err -> failWith $ T.pack $ "thunk update: " <> show err
440+ -- check to see if thunk should be updated to a specific branch or just update it's current branch
335− Right c -> case c of
441+ case mBranch of
336− ThunkData_Packed t -> return (target, t)
442+ Nothing -> do
337− ThunkData_Checkout _ -> failWith "cannot update an unpacked thunk"
443+ (overwrite, ptr) <- readThunk target >>= \case
338− let src = _thunkPtr_source ptr
444+ Left err -> failWith [i|Thunk update: ${err}|]
339− rev <- liftIO $ getLatestRev src
445+ Right c -> case c of
340− overwriteThunk overwrite $ ThunkPtr
446+ ThunkData_Packed _ t -> return (target, t)
341− { _thunkPtr_source = src
447+ ThunkData_Checkout -> failWith "cannot update an unpacked thunk"
342− , _thunkPtr_rev = rev
448+ let src = _thunkPtr_source ptr
343− }
449+ rev <- getLatestRev src
450+ overwriteThunk overwrite $ modifyThunkPtrByConfig thunkConfig $ ThunkPtr
451+ { _thunkPtr_source = src
452+ , _thunkPtr_rev = rev
454+ Just branch -> readThunk target >>= \case
455+ Left err -> failWith [i|Thunk update: ${err}|]
456+ Right c -> case c of
457+ ThunkData_Packed _ t -> setThunk thunkConfig target (thunkSourceToGitSource $ _thunkPtr_source t) branch
458+ ThunkData_Checkout -> failWith [i|Thunk located at ${target} is unpacked. Use 'ob thunk pack' on the desired directory and then try 'ob thunk update' again.|]
460+ spinner = withSpinner' ("Updating thunk " <> T.pack target <> " to latest") (pure $ const $ "Thunk " <> T.pack target <> " updated to latest")
462+setThunk :: MonadObelisk m => ThunkConfig -> FilePath -> GitSource -> String -> m ()
463+setThunk thunkConfig target gs branch = do
464+ newThunkPtr <- uriThunkPtr (_gitSource_url gs) (_thunkConfig_private thunkConfig) (Just $ T.pack branch) Nothing
465+ overwriteThunk target newThunkPtr
466+ updateThunkToLatest (ThunkUpdateConfig Nothing thunkConfig) target
345-- | All recognized github standalone loaders, ordered from newest to oldest.
468-- | All recognized github standalone loaders, ordered from newest to oldest.
346-- 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.
347−gitHubStandaloneLoaders :: NonEmpty Text
470+gitHubThunkSpecs :: NonEmpty ThunkSpec
348−gitHubStandaloneLoaders =
471+gitHubThunkSpecs =
349− gitHubStandaloneLoaderV3 :|
472+ gitHubThunkSpecV5 :|
350− [ gitHubStandaloneLoaderV2
473+ [ gitHubThunkSpecV4
351− , gitHubStandaloneLoaderV1
474+ , gitHubThunkSpecV3
354−gitHubStandaloneLoaderV1 :: Text
479+gitHubThunkSpecV1 :: ThunkSpec
355−gitHubStandaloneLoaderV1 = T.unlines
480+gitHubThunkSpecV1 = legacyGitHubThunkSpec "github-v1"
356− [ "import ((import <nixpkgs> {}).fetchFromGitHub (builtins.fromJSON (builtins.readFile ./github.json)))"
481+ "import ((import <nixpkgs> {}).fetchFromGitHub (builtins.fromJSON (builtins.readFile ./github.json)))"
359−gitHubStandaloneLoaderV2 :: Text
483+gitHubThunkSpecV2 :: ThunkSpec
360−gitHubStandaloneLoaderV2 = T.unlines
484+gitHubThunkSpecV2 = legacyGitHubThunkSpec "github-v2" $ T.unlines
361 [ "# 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.
362 , "import ((import <nixpkgs> {}).fetchFromGitHub ("
486 , "import ((import <nixpkgs> {}).fetchFromGitHub ("
363 , " let json = builtins.fromJSON (builtins.readFile ./github.json);"
487 , " let json = builtins.fromJSON (builtins.readFile ./github.json);"
@@ -367,8 +491,8 @@ gitHubStandaloneLoaderV2 = T.unlines
370−gitHubStandaloneLoaderV3 :: Text
494+gitHubThunkSpecV3 :: ThunkSpec
371−gitHubStandaloneLoaderV3 = T.unlines
495+gitHubThunkSpecV3 = legacyGitHubThunkSpec "github-v3" $ T.unlines
372 [ "# DO NOT HAND-EDIT THIS FILE"
496 [ "# DO NOT HAND-EDIT THIS FILE"
374 , " fetch = { private ? false, ... }@args: if private && builtins.hasAttr \"fetchGit\" builtins"
498 , " fetch = { private ? false, ... }@args: if private && builtins.hasAttr \"fetchGit\" builtins"
@@ -387,32 +511,151 @@ gitHubStandaloneLoaderV3 = T.unlines
387 , "in import (fetch (builtins.fromJSON (builtins.readFile ./github.json)))"
511 , "in import (fetch (builtins.fromJSON (builtins.readFile ./github.json)))"
390−plainGitStandaloneLoaders :: NonEmpty Text
514+gitHubThunkSpecV4 :: ThunkSpec
391−plainGitStandaloneLoaders =
515+gitHubThunkSpecV4 = legacyGitHubThunkSpec "github-v4" $ T.unlines
392− plainGitStandaloneLoaderV1 :|
516+ [ "# DO NOT HAND-EDIT THIS FILE"
393− [
517+ , "let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }:"
518+ , " if !fetchSubmodules && !private then builtins.fetchTarball {"
519+ , " url = \"https://github.com/${owner}/${repo}/archive/${rev}.tar.gz\"; inherit sha256;"
520+ , " } else (import <nixpkgs> {}).fetchFromGitHub {"
521+ , " inherit owner repo rev sha256 fetchSubmodules private;"
523+ , "in import (fetch (builtins.fromJSON (builtins.readFile ./github.json)))"
526+legacyGitHubThunkSpec :: Text -> Text -> ThunkSpec
527+legacyGitHubThunkSpec name loader = ThunkSpec name $ Map.fromList
528+ [ ("default.nix", ThunkFileSpec_FileMatches $ T.strip loader)
529+ , ("github.json" , ThunkFileSpec_Ptr parseGitHubJsonBytes)
530+ , (attrCacheFileName, ThunkFileSpec_AttrCache)
531+ , (".git", ThunkFileSpec_CheckoutIndicator)
534+gitHubThunkSpecV5 :: ThunkSpec
535+gitHubThunkSpecV5 = mkThunkSpec "github-v5" "github.json" parseGitHubJsonBytes [here|
536+# DO NOT HAND-EDIT THIS FILE
537+let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }:
538+ if !fetchSubmodules && !private then builtins.fetchTarball {
539+ url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256;
540+ } else (import <nixpkgs> {}).fetchFromGitHub {
541+ inherit owner repo rev sha256 fetchSubmodules private;
543+ json = builtins.fromJSON (builtins.readFile ./github.json);
547+parseGitHubJsonBytes :: LBS.ByteString -> Either String ThunkPtr
548+parseGitHubJsonBytes = parseJsonObject $ parseThunkPtr $ \v ->
549+ ThunkSource_GitHub <$> parseGitHubSource v <|> ThunkSource_Git <$> parseGitSource v
551+gitThunkSpecs :: NonEmpty ThunkSpec
560+gitThunkSpecV1 :: ThunkSpec
561+gitThunkSpecV1 = legacyGitThunkSpec "git-v1" $ T.unlines
562+ [ "# DO NOT HAND-EDIT THIS FILE"
563+ , "let fetchGit = {url, rev, ref ? null, branch ? null, sha256 ? null, fetchSubmodules ? null}:"
564+ , " assert !fetchSubmodules; (import <nixpkgs> {}).fetchgit { inherit url rev sha256; };"
565+ , "in import (fetchGit (builtins.fromJSON (builtins.readFile ./git.json)))"
396−plainGitStandaloneLoaderV1 :: Text
568+gitThunkSpecV2 :: ThunkSpec
397−plainGitStandaloneLoaderV1 = T.unlines
569+gitThunkSpecV2 = legacyGitThunkSpec "git-v2" $ T.unlines
398− [ $notImplemented
570+ [ "# DO NOT HAND-EDIT THIS FILE"
571+ , "let fetchGit = {url, rev, ref ? null, branch ? null, sha256 ? null, fetchSubmodules ? null}:"
572+ , " if builtins.hasAttr \"fetchGit\" builtins"
573+ , " then builtins.fetchGit ({ inherit url rev; } // (if branch == null then {} else { ref = branch; }))"
574+ , " else abort \"Plain Git repositories are only supported on nix 2.0 or higher.\";"
575+ , "in import (fetchGit (builtins.fromJSON (builtins.readFile ./git.json)))"
401−-- | Look for authentication info from the 'hub' command
578+-- This loader has a bug because @builtins.fetchGit@ is not given a @ref@
402−getHubAuth
579+-- and will fail to find commits without this because it does shallow clones.
403− :: Text -- ^ Domain name
580+gitThunkSpecV3 :: ThunkSpec
404− -> IO (Maybe Auth)
581+gitThunkSpecV3 = legacyGitThunkSpec "git-v3" $ T.unlines
405−getHubAuth domain = do
582+ [ "# DO NOT HAND-EDIT THIS FILE"
406− hubConfig <- getXdgDirectory XdgConfig "hub"
583+ , "let fetch = {url, rev, ref ? null, sha256 ? null, fetchSubmodules ? false, private ? false, ...}:"
407− Yaml.decodeFile hubConfig >>= \case
584+ , " let realUrl = let firstChar = builtins.substring 0 1 url; in"
408− Nothing -> return Nothing
585+ , " if firstChar == \"/\" then /. + url"
409− Just v -> return $ flip parseMaybe v $ \v' -> do
586+ , " else if firstChar == \".\" then ./. + url"
410− Yaml.Array domainConfigs <- v' .: domain --TODO: Determine what multiple domainConfigs means
587+ , " else url;"
411− [Yaml.Object domainConfig] <- return $ toList domainConfigs
588+ , " in if !fetchSubmodules && private then builtins.fetchGit {"
412− token <- domainConfig .: "oauth_token"
589+ , " url = realUrl; inherit rev;"
413− return $ OAuth $ encodeUtf8 token
590+ , " } else (import <nixpkgs> {}).fetchgit {"
414−
591+ , " url = realUrl; inherit rev sha256;"
415−--TODO: when checking something out, make a shallow clone
592+ , " };"
593+ , "in import (fetch (builtins.fromJSON (builtins.readFile ./git.json)))"
596+gitThunkSpecV4 :: ThunkSpec
597+gitThunkSpecV4 = legacyGitThunkSpec "git-v4" $ T.unlines
598+ [ "# DO NOT HAND-EDIT THIS FILE"
599+ , "let fetch = {url, rev, branch ? null, sha256 ? null, fetchSubmodules ? false, private ? false, ...}:"
600+ , " let realUrl = let firstChar = builtins.substring 0 1 url; in"
601+ , " if firstChar == \"/\" then /. + url"
602+ , " else if firstChar == \".\" then ./. + url"
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
417-- | 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
418-- to the result of building an attribute of a thunk.
661-- to the result of building an attribute of a thunk.
@@ -420,42 +663,49 @@ getHubAuth domain = do
420-- and the result is symlinked into the cache.
663-- and the result is symlinked into the cache.
421nixBuildThunkAttrWithCache
664nixBuildThunkAttrWithCache
422 :: MonadObelisk m
665 :: MonadObelisk m
423− => FilePath
666+ => ThunkSpec
424 -- ^ Path to directory containing Thunk
668 -- ^ Path to directory containing Thunk
425 -> String
669 -> String
426 -- ^ Attribute to build
670 -- ^ Attribute to build
427− -> m FilePath
671+ -> m (Maybe FilePath)
428 -- ^ Symlink to cached or built nix output
672 -- ^ Symlink to cached or built nix output
429-- WARNING: If the thunk uses an impure reference such as '<nixpkgs>'
673-- WARNING: If the thunk uses an impure reference such as '<nixpkgs>'
430-- the caching mechanism will fail as it merely measures the modification
674-- the caching mechanism will fail as it merely measures the modification
431-- time of the cache link and the expression to build.
675-- time of the cache link and the expression to build.
432−nixBuildThunkAttrWithCache thunkDir attr = do
676+nixBuildThunkAttrWithCache thunkSpec thunkDir attr = do
433− --NB: Expects thunkDir to be normalised with no trailing path separator.
677+ latestChange <- liftIO $ do
434− --This should be guaranteed by the command argument parser.
678+ let
435− let cacheErrHandler e
679+ getModificationTimeMaybe = fmap rightToMaybe . try @IOError . getModificationTime
436− | isDoesNotExistError e = return Nothing -- expected from a cache miss
680+ thunkFileNames = Map.keys $ _thunkSpec_files thunkSpec
437− | otherwise = putLog Error (T.pack $ displayException e) >> return Nothing
681+ maximum . catMaybes <$> traverse (getModificationTimeMaybe . (thunkDir </>)) thunkFileNames
438− cacheDir = thunkDir </> ".attr-cache"
682+
439− cachePath = cacheDir </> attr <.> "out"
683+ let cachePaths' = nonEmpty $ Map.keys $ Map.filter (\case ThunkFileSpec_AttrCache -> True; _ -> False) $
440− liftIO $ createDirectoryIfMissing False cacheDir
684+ _thunkSpec_files thunkSpec
441− latestChange <- liftIO $ maximum <$> mapM (getModificationTime . (thunkDir </>)) ["default.nix", "github.json"]
685+ for cachePaths' $ \cachePaths ->
442− cacheHit <- handle cacheErrHandler $ do
686+ fmap NonEmpty.head $ for cachePaths $ \cacheDir -> do
443− cacheTime <- liftIO $ posixSecondsToUTCTime . realToFrac . modificationTime <$> getSymbolicLinkStatus cachePath
687+ let
444− return $ if latestChange <= cacheTime
688+ cachePath = thunkDir </> cacheDir </> attr <.> "out"
445− then Just cachePath
689+ cacheErrHandler e
446− else Nothing
690+ | isDoesNotExistError e = pure Nothing -- expected from a cache miss
447− case cacheHit of
691+ | otherwise = Nothing <$ putLog Error (T.pack $ displayException e)
448− Just c -> return c
692+ cacheHit <- handle cacheErrHandler $ do
449− Nothing -> do
693+ cacheTime <- liftIO $ posixSecondsToUTCTime . realToFrac . modificationTime <$> getSymbolicLinkStatus cachePath
450− putLog Warning $ T.pack $ mconcat [thunkDir, ": ", attr, " not cached, building ..."]
694+ pure $ if latestChange <= cacheTime
451− _ <- nixBuild $ def
695+ then Just cachePath
452− { _nixBuildConfig_target = Target
696+ else Nothing
453− { _target_path = thunkDir
697+ case cacheHit of
454− , _target_attr = Just attr
698+ Just c -> pure c
456− , _nixBuildConfig_outLink = OutLink_IndirectRoot cachePath
700+ putLog Warning $ T.pack $ mconcat [thunkDir, ": ", attr, " not cached, building ..."]
457− }
701+ liftIO $ createDirectoryIfMissing True (takeDirectory cachePath)
458− return 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
460-- | Build a nix attribute, and cache the result if possible
710-- | Build a nix attribute, and cache the result if possible
461nixBuildAttrWithCache
711nixBuildAttrWithCache
@@ -466,212 +716,476 @@ nixBuildAttrWithCache
466 -- ^ Attribute to build
716 -- ^ Attribute to build
467 -> m FilePath
717 -> m FilePath
468 -- ^ Symlink to cached or built nix output
718 -- ^ Symlink to cached or built nix output
469−nixBuildAttrWithCache exprPath attr = do
719+nixBuildAttrWithCache exprPath attr = readThunk exprPath >>= \case
470− readThunk exprPath >>= \case
720+ -- Only packed thunks are cached. In particular, checkouts are not.
471− -- Only packed thunks are cached. in particular, checkouts are not
721+ Right (ThunkData_Packed spec _) ->
472− Right (ThunkData_Packed _) -> nixBuildThunkAttrWithCache exprPath attr
722+ maybe build pure =<< nixBuildThunkAttrWithCache spec exprPath attr
473− _ -> nixBuild $ def
723+ _ -> build
474− { _nixBuildConfig_target = Target
724+ where
475− { _target_path = exprPath
725+ build = nixCmd $ NixCmd_Build $ def
726+ & nixBuildConfig_outLink .~ OutLink_None
727+ & nixCmdConfig_target .~ Target
728+ { _target_path = Just exprPath
476 , _target_attr = Just attr
729 , _target_attr = Just attr
730+ , _target_expr = Nothing
478− , _nixBuildConfig_outLink = OutLink_None
481−unpackThunk
733+-- | Safely update thunk using a custom action
482− :: MonadObelisk m
734+--
483− => FilePath
735+-- A temporary working space is used to do any update. When the custom
484− -> m ()
736+-- action successfully completes, the resulting (packed) thunk is copied
485−unpackThunk thunkDir = readThunk thunkDir >>= \case
737+-- back to the original location.
486− Left err -> failWith $ "thunk unpack: " <> (T.pack $ show err)
738+updateThunk :: MonadObelisk m => FilePath -> (FilePath -> m a) -> m a
487− --TODO: Overwrite option that rechecks out thunk; force option to do so even if working directory is dirty
739+updateThunk p f = withSystemTempDirectory "obelisk-thunkptr-" $ \tmpDir -> do
488− Right (ThunkData_Checkout _) -> failWith "thunk unpack: thunk is already unpacked"
740+ p' <- copyThunkToTmp tmpDir p
489− Right (ThunkData_Packed tptr) -> case _thunkPtr_source tptr of
741+ unpackThunk' True p'
490− ThunkSource_GitHub s | (thunkParent, thunkName) <- splitFileName thunkDir -> withTempDirectory thunkParent thunkName $ \tmpRepo -> do
742+ result <- f p'
491− mauth <- liftIO $ getHubAuth "github.com"
743+ updateThunkFromTmp p'
492− repoResult <- liftIO $ executeRequestMaybe mauth $ repositoryR (_gitHubSource_owner s) (_gitHubSource_repo s)
744+ return result
493− githubURI <- liftIO $ either throwIO (return . repoSshUrl) repoResult >>= \case
745+ where
494− Nothing -> fail "Cannot determine clone URI for thunk source"
746+ copyThunkToTmp tmpDir thunkDir = readThunk thunkDir >>= \case
495− Just c -> return $ T.unpack $ getUrl c
747+ Left err -> failWith $ "withThunkUnpacked: " <> T.pack (show err)
496− withSpinner ("Retrieving thunk " <> T.pack thunkName <> " from GitHub") $ do
748+ Right ThunkData_Packed{} -> do
497− callProcessAndLogOutput (Notice, Notice) $
749+ let tmpThunk = tmpDir </> "thunk"
498− proc "hub" ["clone", "-n", githubURI, tmpRepo]
499− let obGitDir = tmpRepo </> ".git" </> "obelisk"
500− --If this directory already exists then something is weird and we should fail
501− liftIO $ createDirectory obGitDir
502− callProcessAndLogOutput (Notice, Error) $
503− cp ["-r", "-T", thunkDir </> ".", obGitDir </> "orig-thunk"]
504− withSpinner ("Preparing thunk in " <> T.pack thunkDir) $ do
506− putLog Notice $ "Checking out " <> T.pack (show $ maybe "" untagName $ _gitHubSource_branch s)
507− callProcessAndLogOutput (Notice, Notice) $
511− , maybe [] (\n -> ["-B", T.unpack (untagName n)]) (_gitHubSource_branch s)
512− , pure $ Ref.toHexString $ _thunkRev_commit $ _thunkPtr_rev tptr
514− -- Set upstream branch
515− forM_ (_gitHubSource_branch s) $ \branch ->
516− callProcessAndLogOutput (Notice, Error) $
517− proc "hub" ["-C", tmpRepo, "branch", "-u", "origin/" <> T.unpack (untagName branch)]
518− callProcessAndLogOutput (Notice, Error) $
519− proc "rm" ["-r", thunkDir]
520 callProcessAndLogOutput (Notice, Error) $
750 callProcessAndLogOutput (Notice, Error) $
521− procWithPackages ["coreutils"] "mv"
751+ proc cp ["-r", "-T", thunkDir, tmpThunk]
522− [ "-T"
752+ return tmpThunk
523− , tmpRepo
753+ Right _ -> failWith "Thunk is not packed"
524− , thunkDir
754+ updateThunkFromTmp p' = do
525− ]
755+ _ <- packThunk' True (ThunkPackConfig False (ThunkConfig Nothing)) p'
526− ThunkSource_Git _s -> do
756+ callProcessAndLogOutput (Notice, Error) $
527− $notImplemented
757+ proc cp ["-r", "-T", p', p]
529−--TODO: add force mode to pack even if changes are present
759+finalMsg :: Bool -> (a -> Text) -> Maybe (a -> Text)
530−--TODO: add a rollback mode to pack to the original thunk
760+finalMsg 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|]
776+unpackThunk :: MonadObelisk m => FilePath -> m ()
777+unpackThunk = unpackThunk' False
779+unpackThunk' :: MonadObelisk m => Bool -> FilePath -> m ()
780+unpackThunk' noTrail thunkDir = checkThunkDirectory thunkDir *> readThunk thunkDir >>= \case
781+ Left err -> failWith [i|Invalid thunk at ${thunkDir}: ${err}|]
782+ --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|]
784+ Right (ThunkData_Packed _ tptr) -> do
785+ let (thunkParent, thunkName) = splitFileName thunkDir
786+ withTempDirectory thunkParent thunkName $ \tmpThunk -> do
788+ gitSrc = thunkSourceToGitSource $ _thunkPtr_source tptr
789+ newSpec = case _thunkPtr_source tptr of
790+ ThunkSource_GitHub _ -> NonEmpty.head gitHubThunkSpecs
791+ ThunkSource_Git _ -> NonEmpty.head gitThunkSpecs
792+ withSpinner' ("Fetching thunk " <> T.pack thunkName)
793+ (finalMsg noTrail $ const $ "Fetched thunk " <> T.pack thunkName) $ do
794+ let unpackedPath = tmpThunk </> unpackedDirName
795+ gitCloneForThunkUnpack gitSrc (_thunkRev_commit $ _thunkPtr_rev tptr) unpackedPath
797+ let normalizeMore = dropTrailingPathSeparator . normalise
798+ when (normalizeMore unpackedPath /= normalizeMore tmpThunk) $ -- Only write meta data if the checkout is not inplace
799+ createThunk tmpThunk $ Left newSpec
802+ removePathForcibly thunkDir
803+ renameDirectory tmpThunk thunkDir
805+gitCloneForThunkUnpack
532 :: MonadObelisk m
806 :: MonadObelisk m
533− => FilePath
807+ => GitSource -- ^ Git source to use
534− -> String
808+ -> Ref hash -- ^ Commit hash to reset to
809+ -> FilePath -- ^ Directory to clone into
536−packThunk thunkDir upstream = readThunk thunkDir >>= \case
811+gitCloneForThunkUnpack gitSrc commit dir = do
537− Left err -> failWith $ T.pack $ "thunk pack: " <> show err
812+ let git = callProcessAndLogOutput (Notice, Notice) . gitProc dir
538− Right (ThunkData_Packed _) -> failWith "pack: thunk is already packed"
813+ git $ [ "clone" ]
539− Right (ThunkData_Checkout _) -> do
814+ ++ ["--recursive" | _gitSource_fetchSubmodules gitSrc]
540− thunkPtr <- getThunkPtr thunkDir upstream
815+ ++ [ T.unpack $ gitUriToText $ _gitSource_url gitSrc ]
541− liftIO $ callProcess "rm"
816+ ++ do branch <- maybeToList $ _gitSource_branch gitSrc
542− [ "-rf"
817+ [ "--branch", T.unpack $ untagName branch ]
543− , thunkDir
818+ git ["reset", "--hard", Ref.toHexString commit]
819+ when (_gitSource_fetchSubmodules gitSrc) $
820+ git ["submodule", "update", "--recursive", "--init"]
822+--TODO: add a rollback mode to pack to the original thunk
823+packThunk :: MonadObelisk m => ThunkPackConfig -> FilePath -> m ThunkPtr
824+packThunk = packThunk' False
826+packThunk' :: MonadObelisk m => Bool -> ThunkPackConfig -> FilePath -> m ThunkPtr
827+packThunk' noTrail (ThunkPackConfig force thunkConfig) thunkDir = checkThunkDirectory thunkDir *> readThunk thunkDir >>= \case
828+ Right ThunkData_Packed{} -> failWith [i|Thunk at ${thunkDir} is is already packed|]
830+ ("Packing thunk " <> T.pack thunkDir)
831+ (finalMsg noTrail $ const $ "Packed thunk " <> T.pack 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
836+ createThunk thunkDir $ Right thunkPtr
839+modifyThunkPtrByConfig :: ThunkConfig -> ThunkPtr -> ThunkPtr
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
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"]
874+ unless (T.null stashOutput) $
875+ failWith $ T.unlines $
876+ [ "thunk pack: thunk checkout has stashes"
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."
892+ -- Get information on all branches and their (optional) designated upstream
894+ headDump :: [Text] <- T.lines <$> readGitProcess thunkDir
896+ , "--format=%(refname:short) %(upstream:short) %(upstream:remotename)"
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
920+ when checkClean $ do
921+ let untrackedBranches = Map.keys errorMap
922+ when (not $ L.null untrackedBranches) $ failWith $ T.unlines $
923+ [ "thunk pack: Certain branches in the thunk have no upstream branch \
924+ \set. This means we don't know to check whether all your work is \
925+ \saved. The offending branches are:"
927+ , T.unwords untrackedBranches
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."
545− withSpinner ("Packing thunk " <> T.pack thunkDir) $
938+
546− liftIO $ createThunk thunkDir thunkPtr
939+ -- loosely by https://stackoverflow.com/questions/7773939/show-git-ahead-and-behind-info-for-all-branches-including-remotes
547−
940+ stats <- ifor headUpstream $ \branch (upstream, _remote) -> do
548−getThunkPtr :: MonadObelisk m => FilePath -> String -> m ThunkPtr
941+ (stat :: [Text]) <- T.lines <$> readGitProcess thunkDir
549−getThunkPtr thunkDir upstream = do
942+ [ "rev-list", "--left-right"
550− liftIO (checkGitCleanStatus thunkDir) >>= \case
943+ , T.unpack branch <> "..." <> T.unpack upstream
552− statusDebug <- liftIO $ fmap (T.strip . T.pack) $ readProcess "hub"
945+ let ahead = length $ [ () | Just ('<', _) <- T.uncons <$> stat ]
553− [ "-C", thunkDir, "status", "--ignored" ] ""
946+ behind = length $ [ () | Just ('>', _) <- T.uncons <$> stat ]
554− putLog Warning "cannot proceed with unsaved working copy (git status):"
947+ pure (upstream, (ahead, behind))
555− putLog Notice statusDebug
948+
556− failWith "thunk pack: thunk checkout contains unsaved modifications"
949+ -- Those branches which have commits ahead of, i.e. not on, the upstream
557− True -> return ()
950+ -- branch. Purely being behind is fine.
558−
951+ let nonGood = Map.filter ((/= 0) . fst . snd) stats
559− -- Check whether there are any stashes
952+
560− stashOutput <- liftIO $ fmap T.pack $ readProcess "hub" [ "-C", thunkDir, "stash", "list" ] ""
953+ when (not $ Map.null nonGood) $ failWith $ T.unlines $
561− case T.null stashOutput of
954+ [ "thunk pack: Certain branches in the thunk have commits not yet pushed upstream:"
562− False -> do
955+ , ""
563− failWith $ T.unlines $
956+ ] ++
564− [ "thunk pack: thunk checkout has stashes"
957+ flip map (Map.toList nonGood) (\(branch, (upstream, (ahead, behind))) -> mconcat
565− , "git stash list:"
958+ [" ", branch, " ahead: ", T.pack (show ahead), " behind: ", T.pack (show behind), " remote branch ", upstream]) ++
566− ] ++ T.lines stashOutput
959+ [ ""
567− True -> return ()
960+ , "Please push these upstream and try again. (Or just fetch, if they are somehow \
568−
961+ \pushed but this repo's remote tracking branches don't know it.)"
569− --Check whether all local heads are pushed
962+ ]
570− repoHeads <- liftIO $ lines <$> readProcess "hub"
963+
571− [ "-C", thunkDir
964+ when checkClean $ do
572− , "for-each-ref", "--format=%(refname:short)", "refs/heads/"
965+ -- We assume it's safe to pack the thunk at this point
573− ] ""
966+ putLog Informational "All changes safe in git remotes. OK to pack thunk."
574− remotes <- liftIO $ lines <$> readProcess "hub" [ "-C", thunkDir, "remote" ] ""
967+
575− --Check that the upstream specified actually exists
968+ let remote = maybe "origin" snd $ flip Map.lookup headUpstream =<< mCurrentBranch
576− case L.find (== upstream) remotes of
969+
577− Nothing -> failWith $ T.pack $ "thunk pack: upstream " <> upstream <> " does not exist. Available upstreams are " <> L.intercalate ", " remotes
970+ [remoteUri'] <- fmap T.lines $ readGitProcess thunkDir
578− Just _ -> return ()
971+ [ "config"
579− -- iterate over cartesian product
972+ , "--get"
580− forM_ repoHeads $ \hd -> do
973+ , "remote." <> T.unpack remote <> ".url"
581− [localRev] <- liftIO $ lines <$> readProcess "hub" [ "-C", thunkDir, "rev-parse", hd ] ""
974+ ]
582− forM_ remotes $ \rm -> do
975+
583− --TODO: The error you get if a branch isn't pushed anywhere could be made more user friendly
976+ remoteUri <- case parseGitUri remoteUri' of
584− [remoteMergeRev] <- liftIO $ lines <$> readProcess "hub"
977+ Nothing -> failWith $ "Could not identify git remote: " <> remoteUri'
585− [ "-C", thunkDir
978+ Just uri -> pure uri
586− , "merge-base"
979+ uriThunkPtr remoteUri mPrivate mCurrentBranch mCurrentCommit
588− , "remotes/" <> rm <> "/" <> hd
981+-- | Get the latest revision available from the given source
589− ] ""
982+getLatestRev :: MonadObelisk m => ThunkSource -> m ThunkRev
590− case remoteMergeRev == localRev of
983+getLatestRev os = do
591− False -> failWith $ T.pack $ mconcat [ "thunk unpack: branch ", hd, " has not been pushed to ", rm ]
984+ let gitS = thunkSourceToGitSource os
592− True -> return ()
985+ (_, commit) <- gitGetCommitBranch (_gitSource_url gitS) (untagName <$> _gitSource_branch gitS)
594− --We assume it's safe to pack the thunk at this point
987+ ThunkSource_GitHub s -> githubThunkRev s commit
595− [remoteUri'] <- liftIO $ lines <$> readProcess "hub"
988+ ThunkSource_Git s -> gitThunkRev s commit
596− [ "-C", thunkDir
989+
597− , "config", "--get", "remote." <> upstream <> ".url"
990+-- | Convert a URI to a thunk
599−
992+-- If the URL is a github URL, we try to just download an archive for
600− let uriParseFailure = "Could not identify git remote: " <> remoteUri'
993+-- performance. If that doesn't work (e.g. authentication issue), we fall back
601− mRemoteUri = parseURIReference remoteUri'
994+-- on just doing things the normal way for git repos in general, and save it as
602− <|> parseSshShorthand remoteUri'
995+-- a regular git thunk.
603− case mRemoteUri of
996+uriThunkPtr :: MonadObelisk m => GitUri -> Maybe Bool -> Maybe Text -> Maybe Text -> m ThunkPtr
604− Nothing -> failWith $ T.pack uriParseFailure
997+uriThunkPtr uri mPrivate mbranch mcommit = do
605− Just remoteUri -> liftIO $ do
998+ commit <- case mcommit of
606− refs <- fmap (refsToTuples . words) . lines <$> readProcess "hub"
999+ Nothing -> gitGetCommitBranch uri mbranch >>= return . snd
607− [ "-C"
1000+ (Just c) -> return c
608− , thunkDir
1001+ (src, rev) <- uriToThunkSource uri mPrivate mbranch >>= \case
609− , "show-ref"
1002+ ThunkSource_GitHub s -> do
610− , "--head" ] ""
1003+ rev <- runExceptT $ githubThunkRev s commit
611− -- safe because exactly one hash is associated with HEAD
1004+ case rev of
612− let Just currentHead = fst <$> L.find ((== "HEAD") . snd) refs
1005+ Right r -> pure (ThunkSource_GitHub s, r)
613− remoteHeads = Map.fromList $ catMaybes $ fmap
1006+ Left e -> do
614− (\(x,y) -> (,) x <$> L.stripPrefix ("refs/remotes/" <> upstream <> "/") y)
1007+ putLog Warning "\
615− refs
1008+\Failed to fetch archive from GitHub. This is probably a private repo. \
616− localHeads = Map.fromList $ catMaybes $ fmap
1009+\Falling back on normal fetchgit. Original failure:"
617− (\(x,y) -> (,) x <$> L.stripPrefix "refs/heads/" y)
1010+ errorToWarning e
618− refs
1011+ let s' = forgetGithub True s
619− currentUpstreamBranch = Map.lookup currentHead remoteHeads
1012+ (,) (ThunkSource_Git s') <$> gitThunkRev s' commit
620− <|> Map.lookup currentHead localHeads
1013+ ThunkSource_Git s -> (,) (ThunkSource_Git s) <$> gitThunkRev s commit
621− if
1014+ pure $ ThunkPtr
622− | isGithubThunk remoteUri -> githubThunkPtr remoteUri currentHead currentUpstreamBranch
1015+ { _thunkPtr_rev = rev
623− | otherwise -> gitThunkPtr remoteUri currentHead currentUpstreamBranch
1016+ , _thunkPtr_source = src
625− refsToTuples [x, y] = (x, y)
1018+
626− refsToTuples x = error $ "thunk pack: cannot parse ref " <> show x
1019+-- | N.B. Cannot infer all fields.
627− isGithubThunk u
1020+--
628− | Just uriAuth <- uriAuthority u
1021+-- If the thunk is a GitHub thunk and fails, we do *not* fall back like with
629− = case uriScheme u of
1022+-- `uriThunkPtr`. Unlike a plain URL, a thunk src explicitly states which method
630− "ssh:" -> uriAuth == URIAuth "git@" "github.com" ""
1023+-- should be employed, and so we respect that.
631− s -> s `L.elem` [ "git:", "https:", "http:" ] -- "http:" just redirects to "https:"
1024+uriToThunkSource :: MonadObelisk m => GitUri -> Maybe Bool -> Maybe Text -> m ThunkSource
632− && uriRegName uriAuth == "github.com"
1025+uriToThunkSource (GitUri u) mPrivate
633− | otherwise = False
1026+ | Right uriAuth <- URI.uriAuthority u
634− githubThunkPtr u commit' branch' = do
1027+ , Just scheme <- URI.unRText <$> URI.uriScheme u
635− ["/", owner', repo'] <- return $ splitDirectories (uriPath u)
1028+ , case scheme of
636− let owner = N (T.pack owner')
1029+ "ssh" -> uriAuth == URI.Authority
637− repo = N (T.pack (dropExtension repo'))
1030+ { URI.authUserInfo = Just $ URI.UserInfo (fromRight' $ URI.mkUsername "git") Nothing
638− commit = N (T.pack commit')
1031+ , URI.authHost = fromRight' $ URI.mkHost "github.com"
639− branch = N . T.pack <$> branch'
1032+ , URI.authPort = Nothing
640− mauth <- getHubAuth "github.com"
641− repoResult <- executeRequestMaybe mauth $ repositoryR owner repo
642− repoIsPrivate <- either throwIO (return . repoPrivate) repoResult
643− archiveResult <- executeRequestMaybe mauth $
644− archiveForR owner repo ArchiveFormatTarball (Just (untagName commit))
645− archiveUri <- either throwIO return archiveResult
646− hash <- getNixSha256ForUriUnpacked archiveUri
648− { _thunkPtr_rev = ThunkRev
649− { _thunkRev_commit = commitNameToRef commit
650− , _thunkRev_nixSha256 = hash
652− , _thunkPtr_source = ThunkSource_GitHub $ GitHubSource
1034+ s -> s `L.elem` [ "git", "https", "http" ] -- "http:" just redirects to "https:"
653− { _gitHubSource_owner = owner
1035+ && URI.unRText (URI.authHost uriAuth) == "github.com"
654− , _gitHubSource_repo = repo
1036+ , Just (_, owner :| [repoish]) <- URI.uriPath u
655− , _gitHubSource_branch = branch
1037+ = \mbranch -> do
656− , _gitHubSource_private = repoIsPrivate
1038+ isPrivate <- getIsPrivate
1039+ pure $ ThunkSource_GitHub $ GitHubSource
1040+ { _gitHubSource_owner = N $ URI.unRText owner
1041+ , _gitHubSource_repo = N $ let
1042+ repoish' = URI.unRText repoish
1043+ in fromMaybe repoish' $ T.stripSuffix ".git" repoish'
1044+ , _gitHubSource_branch = N <$> mbranch
1045+ , _gitHubSource_private = isPrivate
1048+ | otherwise = \mbranch -> do
1049+ isPrivate <- getIsPrivate
1050+ pure $ ThunkSource_Git $ GitSource
1051+ { _gitSource_url = GitUri u
1052+ , _gitSource_branch = N <$> mbranch
1053+ , _gitSource_fetchSubmodules = False -- TODO: How do we determine if this should be true?
1054+ , _gitSource_private = isPrivate
1057+ getIsPrivate = maybe (guessGitRepoIsPrivate $ GitUri u) pure mPrivate
1059+guessGitRepoIsPrivate :: MonadObelisk m => GitUri -> m Bool
1060+guessGitRepoIsPrivate uri = flip fix urisToTry $ \loop -> \case
1062+ uriAttempt:xs -> do
1063+ result <- readCreateProcessWithExitCode $
1070+ , T.unpack $ gitUriToText uriAttempt
1073+ (ExitSuccess, _, _) -> pure False -- Must be a public repo
1076+ urisToTry = nubOrd $
1077+ -- Include the original URI if it isn't using SSH because SSH will certainly fail.
1078+ [uri | fmap URI.unRText (URI.uriScheme (unGitUri uri)) /= Just "ssh"] <>
1079+ [changeScheme "https" uri, changeScheme "http" uri]
1080+ changeScheme scheme (GitUri u) = GitUri $ u
1081+ { URI.uriScheme = URI.mkScheme scheme
1082+ , URI.uriAuthority = (\x -> x { URI.authUserInfo = Nothing }) <$> URI.uriAuthority u
659− gitThunkPtr u _commit' _branch' = do
1084+
660− case uriScheme u of
1085+-- Funny signature indicates no effects depend on the optional branch name.
661− "https:" -> return ()
1086+githubThunkRev
662− "git:" -> return ()
1087+ :: forall m
663− _ -> fail "thunk pack: obelisk currently only supports https and git protocols for non-GitHub remotes"
1088+ . MonadObelisk m
664− $notImplemented
1089+ => GitHubSource
665− parseSshShorthand uri' = do
1090+ -> Text
666− -- This is what git does to check that the remote
1091+ -> m ThunkRev
667− -- is not a local file path when parsing shorthand.
1092+githubThunkRev s commit = do
668− -- Last referenced from here:
1093+ owner <- forcePP $ _gitHubSource_owner s
669− -- https://github.com/git/git/blob/95ec6b1b3393eb6e26da40c565520a8db9796e9f/connect.c#L712
1094+ repo <- forcePP $ _gitHubSource_repo s
670− let uri = T.pack uri'
1095+ revTarball <- URI.mkPathPiece $ commit <> ".tar.gz"
671− (authAndHostname, colonAndPath) = T.break (== ':') uri
1096+ let archiveUri = GitUri $ URI.URI
672− properUri = "ssh://" <> authAndHostname <> "/" <> T.drop 1 colonAndPath
1097+ { URI.uriScheme = Just $ fromRight' $ URI.mkScheme "https"
673− -- Shorthand is valid iff a colon is present and it occurs before the first slash
1098+ , URI.uriAuthority = Right $ URI.Authority
674− -- This check is used to disambiguate a filepath containing a colon from shorthand
1099+ { URI.authUserInfo = Nothing
675− guard $ isNothing (T.findIndex (=='/') authAndHostname)
1100+ , URI.authHost = fromRight' $ URI.mkHost "github.com"
676− && not (T.null colonAndPath)
1101+ , URI.authPort = Nothing
677− parseURI $ T.unpack properUri
1102+ }
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
1179+parseSshShorthand uri = do
1180+ -- This is what git does to check that the remote
1181+ -- is not a local file path when parsing shorthand.
1182+ -- Last referenced from here:
1183+ -- https://github.com/git/git/blob/95ec6b1b3393eb6e26da40c565520a8db9796e9f/connect.c#L712
1185+ (authAndHostname, colonAndPath) = T.break (== ':') uri
1186+ properUri = "ssh://" <> authAndHostname <> "/" <> T.drop 1 colonAndPath
1187+ -- Shorthand is valid iff a colon is present and it occurs before the first slash
1188+ -- This check is used to disambiguate a filepath containing a colon from shorthand
1189+ guard $ isNothing (T.findIndex (=='/') authAndHostname)
1190+ && not (T.null colonAndPath)
1191+ URI.mkURI properUri