@@ -27,10 +27,13 @@ module Obelisk.Command.Thunk
2727 , updateThunk
2828 , getThunkPtr
2929 , getThunkPtr'
30+ , parseGitUri
31+ , uriThunkPtr
3032 ) where
3133
3234import Control.Applicative
33−import Control.Exception (displayException, throwIO, try)
35+import Control.Exception (displayException, try)
36+import Control.Lens.Indexed hiding ((<.>))
3437import Control.Monad
3538import Control.Monad.Catch (handle)
3639import Control.Monad.Except
@@ -40,13 +43,13 @@ import Data.Aeson.Encode.Pretty
4043import qualified Data.Aeson.Types as Aeson
4144import qualified Data.ByteString.Lazy as LBS
4245import Data.Default
43−import Data.Either.Combinators (rightToMaybe)
44−import Data.Foldable
46+import Data.Either.Combinators (fromRight', rightToMaybe)
4547import Data.Git.Ref (Ref)
4648import qualified Data.Git.Ref as Ref
4749import qualified Data.List as L
4850import Data.List.NonEmpty (NonEmpty (..))
4951import qualified Data.List.NonEmpty as NonEmpty
52+import Data.Map (Map)
5053import qualified Data.Map as Map
5154import Data.Maybe
5255import Data.Set (Set)
@@ -56,12 +59,9 @@ import qualified Data.Text as T
5659import Data.Text.Encoding
5760import qualified Data.Text.IO as T
5861import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
59−import Data.Yaml (parseMaybe, (.:))
60−import qualified Data.Yaml as Yaml
62+import Data.Yaml (parseMaybe)
6163import GitHub
6264import GitHub.Data.Name
63−import GitHub.Endpoints.Repos.Contents (archiveForR)
64−import Network.URI
6565import Obelisk.Command.Nix
6666import System.Directory
6767import System.FilePath
@@ -69,6 +69,7 @@ import System.IO.Error
6969import System.IO.Temp
7070import System.Posix (getSymbolicLinkStatus, modificationTime)
7171import System.Process (proc)
72+import Text.URI
7273
7374import Obelisk.App (MonadObelisk)
7475import Obelisk.CliApp
@@ -111,21 +112,43 @@ data GitHubSource = GitHubSource
111112 { _gitHubSource_owner :: Name Owner
112113 , _gitHubSource_repo :: Name Repo
113114 , _gitHubSource_branch :: Maybe (Name Branch)
114− , _gitHubSource_private :: Bool
115115 }
116116 deriving (Show, Eq, Ord)
117117
118118data GitSource = GitSource
119119 { _gitSource_url :: URI
120− , _gitSource_branch :: Name Branch
120+ , _gitSource_branch :: Maybe (Name Branch)
121121 , _gitSource_fetchSubmodules :: Bool
122122 }
123123 deriving (Show, Eq, Ord)
124124
125+-- | Convert a GitHub source to a regular Git source. Assumes no submodules.
126+forgetGithub :: Bool -> GitHubSource -> GitSource
127+forgetGithub useSsh s = GitSource
128+ { _gitSource_url = URI
129+ { uriScheme = Just $ fromRight' $ mkScheme $ if useSsh then "ssh" else "https"
130+ , uriAuthority = Right $ Authority
131+ { authUserInfo = UserInfo (fromRight' $ mkUsername "git") Nothing
132+ <$ guard useSsh
133+ , authHost = fromRight' $ mkHost "github.com"
134+ , authPort = Nothing
135+ }
136+ , uriPath = Just ( False
137+ , fromRight' . mkPathPiece <$>
138+ untagName (_gitHubSource_owner s)
139+ :| [ untagName (_gitHubSource_repo s) <> ".git" ]
140+ )
141+ , uriQuery = []
142+ , uriFragment = Nothing
143+ }
144+ , _gitSource_branch = _gitHubSource_branch s
145+ , _gitSource_fetchSubmodules = False
146+ }
147+
125148getThunkGitBranch :: ThunkPtr -> Maybe Text
126149getThunkGitBranch (ThunkPtr _ src) = fmap untagName $ case src of
127150 ThunkSource_GitHub s -> _gitHubSource_branch s
128− ThunkSource_Git s -> Just $ _gitSource_branch s
151+ ThunkSource_Git s -> _gitSource_branch s
129152
130153commitNameToRef :: Name Commit -> Ref
131154commitNameToRef (N c) = Ref.fromHex $ encodeUtf8 c
@@ -136,17 +159,17 @@ getNixSha256ForUriUnpacked
136159 => URI
137160 -> m NixSha256
138161getNixSha256ForUriUnpacked uri =
139− withExitFailMessage ("nix-prefetch-url: Failed to determine sha256 hash of URL " <> T.pack (show uri)) $ do
140− [hash] <- fmap T.lines $ withNixRemoteCheck $ readProcessAndLogStderr Debug $
141− proc "nix-prefetch-url" ["--unpack" , "--type" , "sha256" , show uri]
162+ withExitFailMessage ("nix-prefetch-url: Failed to determine sha256 hash of URL " <> render uri) $ do
163+ [hash] <- fmap T.lines $ withNixRemoteCheck $ readProcessAndLogOutput (Debug, Debug) $
164+ proc "nix-prefetch-url" ["--unpack" , "--type" , "sha256" , T.unpack $ render uri]
142165 pure hash
143166
144167nixPrefetchGit :: MonadObelisk m => URI -> Text -> Bool -> m NixSha256
145168nixPrefetchGit uri rev fetchSubmodules =
146− withExitFailMessage ("nix-prefetch-git: Failed to determine sha256 hash of Git repo " <> T.pack (show uri) <> " at " <> rev) $ do
169+ withExitFailMessage ("nix-prefetch-git: Failed to determine sha256 hash of Git repo " <> render uri <> " at " <> rev) $ do
147170 out <- withNixRemoteCheck $ readProcessAndLogStderr Debug $
148171 proc "nix-prefetch-git" $ filter (/="")
149− [ "--url", show uri
172+ [ "--url", T.unpack $ render uri
150173 , "--rev", T.unpack rev
151174 , if fetchSubmodules then "--fetch-submodules" else ""
152175 , "--quiet"
@@ -156,56 +179,6 @@ nixPrefetchGit uri rev fetchSubmodules =
156179 Nothing -> failWith $ "nix-prefetch-git: unrecognized output " <> out
157180 Just x -> pure x
158181
159−getLatestGitRev :: MonadObelisk m => GitSource -> m ThunkRev
160−getLatestGitRev s = withSystemTempDirectory "git-clone" $ \tmpDir -> do
161− withExitFailMessage ("Unable to determine latest git revision for branch " <> branch) $ do
162− let git = readProcessAndLogStderr Debug . gitProc tmpDir
163− out <- liftA2 (<>)
164− (git ["clone", "--no-checkout", show $ _gitSource_url s]) -- Might be able to use --bare here instead to go faster.
165− (git ["log", T.unpack branch, "--max-count=1", "--format=%H"])
166−
167− case T.strip <$> safeLast (T.lines out) of
168− Nothing -> failWith $ "Unable to parse git log: " <> out
169− Just rev -> do
170− putLog Debug $ "Latest commit in " <> branch <> " is " <> rev
171− sha <- nixPrefetchGit (_gitSource_url s) rev (_gitSource_fetchSubmodules s)
172− putLog Debug $ "Nix sha256 is " <> sha
173− pure $ ThunkRev
174− { _thunkRev_commit = Ref.fromHexString $ T.unpack rev
175− , _thunkRev_nixSha256 = sha
176− }
177− where
178− remote :: Text = "origin"
179− branch :: Text = remote <> "/" <> untagName (_gitSource_branch s)
180−
181− safeLast [] = Nothing
182− safeLast xs = Just $ last xs
183−
184−-- | Get the latest revision available from the given source
185−getLatestRev :: MonadObelisk m => ThunkSource -> m ThunkRev
186−getLatestRev = \case
187− ThunkSource_GitHub s -> do
188− auth <- liftIO $ getHubAuth "github.com"
189− commitsResult <- liftIO $ executeRequestMaybe auth $ commitsWithOptionsForR
190− (_gitHubSource_owner s)
191− (_gitHubSource_repo s)
192− (FetchAtLeast 1)
193− $ case _gitHubSource_branch s of
194− Nothing -> []
195− Just b -> [CommitQuerySha $ untagName b]
196− commitInfos <- either (liftIO . throwIO) return commitsResult
197− commitInfo : _ <- return $ toList commitInfos
198− let commit = commitSha commitInfo
199− putLog Debug $ "Latest commit is " <> untagName commit
200− Right archiveUri <- liftIO $ executeRequestMaybe auth $ archiveForR (_gitHubSource_owner s) (_gitHubSource_repo s) ArchiveFormatTarball $ Just $ untagName commit
201− nixSha256 <- getNixSha256ForUriUnpacked archiveUri
202− putLog Debug $ "Nix sha256 is " <> nixSha256
203− return $ ThunkRev
204− { _thunkRev_commit = commitNameToRef commit
205− , _thunkRev_nixSha256 = nixSha256
206− }
207− ThunkSource_Git s -> getLatestGitRev s
208−
209182--TODO: Pretty print these
210183data ReadThunkError
211184 = ReadThunkError_UnrecognizedFiles
@@ -314,18 +287,16 @@ parseGitHubSource v = do
314287 owner <- v Aeson..: "owner"
315288 repo <- v Aeson..: "repo"
316289 branch <- v Aeson..:! "branch"
317− mPrivate <- v Aeson..:! "private"
318290 pure $ GitHubSource
319291 { _gitHubSource_owner = owner
320292 , _gitHubSource_repo = repo
321293 , _gitHubSource_branch = branch
322− , _gitHubSource_private = fromMaybe False mPrivate
323294 }
324295
325296parseGitSource :: Aeson.Object -> Aeson.Parser GitSource
326297parseGitSource v = do
327298 Just url <- parseGitUri <$> v Aeson..: "url"
328− branch <- v Aeson..: "branch"
299+ branch <- v Aeson..:! "branch"
329300 fetchSubmodules <- v Aeson..:! "fetchSubmodules"
330301 pure $ GitSource
331302 { _gitSource_url = url
@@ -354,20 +325,14 @@ encodeThunkPtrData (ThunkPtr rev src) = case src of
354325 ThunkSource_GitHub s -> encodePretty' githubCfg $ Aeson.object $ catMaybes
355326 [ Just $ "owner" .= _gitHubSource_owner s
356327 , Just $ "repo" .= _gitHubSource_repo s
357− , case _gitHubSource_branch s of
358− Just b -> Just $ "branch" .= b
359− Nothing -> Nothing
360− , if _gitHubSource_private s
361− then Just $ "private" .= True
362− else Nothing
328+ , ("branch" .=) <$> _gitHubSource_branch s
363329 , Just $ "rev" .= Ref.toHexString (_thunkRev_commit rev)
364330 , Just $ "sha256" .= _thunkRev_nixSha256 rev
365331 ]
366332 ThunkSource_Git s -> encodePretty' plainGitCfg $ Aeson.object $ catMaybes
367− --TODO: Is this safe? read/show is jank for `URI`
368− [ Just $ "url" .= show (_gitSource_url s)
333+ [ Just $ "url" .= render (_gitSource_url s)
369334 , Just $ "rev" .= Ref.toHexString (_thunkRev_commit rev)
370− , Just $ "branch" .= _gitSource_branch s
335+ , ("branch" .=) <$> _gitSource_branch s
371336 , Just $ "sha256" .= _thunkRev_nixSha256 rev
372337 , Just $ "fetchSubmodules" .= _gitSource_fetchSubmodules s
373338 ]
@@ -499,20 +464,6 @@ plainGitStandaloneLoaderV2 = T.unlines
499464thunkFileNames :: [FilePath]
500465thunkFileNames = ["default.nix", "github.json", "git.json"]
501466
502−-- | Look for authentication info from the 'hub' command
503−getHubAuth
504− :: Text -- ^ Domain name
505− -> IO (Maybe Auth)
506−getHubAuth domain = do
507− hubConfig <- getXdgDirectory XdgConfig "hub"
508− Yaml.decodeFileEither hubConfig >>= \case
509− Left _ -> return Nothing
510− Right v -> return $ flip parseMaybe v $ \v' -> do
511− Yaml.Array domainConfigs <- v' .: domain --TODO: Determine what multiple domainConfigs means
512− [Yaml.Object domainConfig] <- return $ toList domainConfigs
513− token <- domainConfig .: "oauth_token"
514− return $ OAuth $ encodeUtf8 token
515−
516467--TODO: when checking something out, make a shallow clone
517468
518469-- | Checks a cache directory to see if there is a fresh symlink
@@ -591,7 +542,7 @@ updateThunk p f = withSystemTempDirectory "obelisk-thunkptr-" $ \tmpDir -> do
591542 p' <- copyThunkToTmp tmpDir p
592543 unpackThunk' True p'
593544 result <- f p'
594− updateThunkFromTmp p' "origin" -- TODO: stop hardcoding remote
545+ updateThunkFromTmp p'
595546 return result
596547 where
597548 copyThunkToTmp tmpDir thunkDir = readThunk thunkDir >>= \case
@@ -602,8 +553,8 @@ updateThunk p f = withSystemTempDirectory "obelisk-thunkptr-" $ \tmpDir -> do
602553 proc "cp" ["-r", "-T", thunkDir, tmpThunk]
603554 return tmpThunk
604555 Right _ -> failWith $ "Thunk is not packed"
605− updateThunkFromTmp p' remote = do
606− packThunk' True p' remote
556+ updateThunkFromTmp p' = do
557+ packThunk' True p'
607558 callProcessAndLogOutput (Notice, Error) $
608559 proc "cp" ["-r", "-T", p', p]
609560
@@ -622,190 +573,316 @@ unpackThunk' noTrail thunkDir = readThunk thunkDir >>= \case
622573 let (thunkParent, thunkName) = splitFileName thunkDir
623574 withTempDirectory thunkParent thunkName $ \tmpRepo -> do
624575 let obGitDir = tmpRepo </> ".git" </> "obelisk"
625− case _thunkPtr_source tptr of
626− ThunkSource_GitHub s -> do
627− mauth <- liftIO $ getHubAuth "github.com"
628− repoResult <- liftIO $ executeRequestMaybe mauth $ repositoryR (_gitHubSource_owner s) (_gitHubSource_repo s)
629− githubURI <- either (liftIO . throwIO) (return . repoSshUrl) repoResult >>= \case
630− Nothing -> failWith "Cannot determine clone URI for thunk source"
631− Just c -> return $ T.unpack $ getUrl c
632−
633− withSpinner' ("Fetching thunk " <> T.pack thunkDir)
634− ( finalMsg noTrail $ const $ "Fetched thunk " <> T.pack thunkDir) $ do
635− callProcessAndLogOutput (Debug, Debug) $
636− proc "hub" ["clone", "-n", githubURI, tmpRepo]
637− --If this directory already exists then something is weird and we should fail
638− liftIO $ createDirectory obGitDir
639− callProcessAndLogOutput (Debug, Error) $
640− proc "cp" ["-r", "-T", thunkDir </> ".", obGitDir </> "orig-thunk"]
641−
642− -- Checkout
643− putLog Debug $ "Checking out " <> T.pack (show $ maybe "" untagName $ _gitHubSource_branch s)
644− callProcessAndLogOutput (Debug, Debug) $
645− proc "hub" $ concat
646− [ ["-C", tmpRepo]
647− , pure "checkout"
648− , maybe [] (\n -> ["-B", T.unpack (untagName n)]) (_gitHubSource_branch s)
649− , pure $ Ref.toHexString $ _thunkRev_commit $ _thunkPtr_rev tptr
650− ]
651− -- Set upstream branch
652− forM_ (_gitHubSource_branch s) $ \branch ->
653− callProcessAndLogOutput (Debug, Error) $
654− proc "hub" ["-C", tmpRepo, "branch", "-u", "origin/" <> T.unpack (untagName branch)]
655− callProcessAndLogOutput (Notice, Error) $ proc "rm" ["-r", thunkDir]
656− callProcessAndLogOutput (Notice, Error) $ proc "mv" ["-T", tmpRepo, thunkDir]
657−
658− ThunkSource_Git s -> do
659− withSpinner' ("Fetching thunk " <> T.pack thunkName)
660− (finalMsg noTrail $ const $ "Fetched thunk " <> T.pack thunkName) $ do
661− let git = callProcessAndLogOutput (Notice, Notice) . gitProc tmpRepo
662− git ["clone", if _gitSource_fetchSubmodules s then "--recursive" else "", show (_gitSource_url s)]
663− git ["reset", "--hard", Ref.toHexString $ _thunkRev_commit $ _thunkPtr_rev tptr]
664− when (_gitSource_fetchSubmodules s) $
665− git ["submodule", "update", "--recursive", "--init"]
666− git ["branch", "-u", "origin/" <> T.unpack (untagName $ _gitSource_branch s)]
667−
668− liftIO $ createDirectory obGitDir
669− callProcessAndLogOutput (Notice, Error) $
670− proc "cp" ["-r", "-T", thunkDir </> ".", obGitDir </> "orig-thunk"]
671− callProcessAndLogOutput (Notice, Error) $
672− proc "rm" ["-r", thunkDir]
673− callProcessAndLogOutput (Notice, Error) $
674− proc "mv" ["-T", tmpRepo, thunkDir]
576+ s = case _thunkPtr_source tptr of
577+ ThunkSource_GitHub s' -> forgetGithub False s'
578+ ThunkSource_Git s' -> s'
579+ withSpinner' ("Fetching thunk " <> T.pack thunkName)
580+ (finalMsg noTrail $ const $ "Fetched thunk " <> T.pack thunkName) $ do
581+ let git = callProcessAndLogOutput (Notice, Notice) . gitProc tmpRepo
582+ git $ [ "clone" ]
583+ ++ ("--recursive" <$ guard (_gitSource_fetchSubmodules s))
584+ ++ [ T.unpack $ render $ _gitSource_url s ]
585+ git ["reset", "--hard", Ref.toHexString $ _thunkRev_commit $ _thunkPtr_rev tptr]
586+ when (_gitSource_fetchSubmodules s) $
587+ git ["submodule", "update", "--recursive", "--init"]
588+ case _gitSource_branch s of
589+ Just b -> git ["branch", "-u", "origin/" <> T.unpack (untagName $ b)]
590+ Nothing -> pure ()
591+
592+ liftIO $ createDirectory obGitDir
593+ callProcessAndLogOutput (Notice, Error) $
594+ proc "cp" ["-r", "-T", thunkDir </> ".", obGitDir </> "orig-thunk"]
595+ callProcessAndLogOutput (Notice, Error) $
596+ proc "rm" ["-r", thunkDir]
597+ callProcessAndLogOutput (Notice, Error) $
598+ proc "mv" ["-T", tmpRepo, thunkDir]
675599
676600--TODO: add force mode to pack even if changes are present
677601--TODO: add a rollback mode to pack to the original thunk
678−packThunk :: MonadObelisk m => FilePath -> Text -> m ()
602+packThunk :: MonadObelisk m => FilePath -> m ()
679603packThunk = packThunk' False
680604
681−packThunk' :: MonadObelisk m => Bool -> FilePath -> Text -> m ()
682−packThunk' noTrail thunkDir upstream = readThunk thunkDir >>= \case
605+packThunk' :: MonadObelisk m => Bool -> FilePath -> m ()
606+packThunk' noTrail thunkDir = readThunk thunkDir >>= \case
683607 Left err -> failWith $ T.pack $ "thunk pack: " <> show err
684608 Right (ThunkData_Packed _) -> failWith "pack: thunk is already packed"
685609 Right (ThunkData_Checkout _) -> do
686610 withSpinner' ("Packing thunk " <> T.pack thunkDir)
687611 (finalMsg noTrail $ const $ "Packed thunk " <> T.pack thunkDir) $ do
688− thunkPtr <- getThunkPtr thunkDir upstream
612+ thunkPtr <- getThunkPtr thunkDir
689613 callProcessAndLogOutput (Debug, Error) $ proc "rm" ["-rf", thunkDir]
690614 liftIO $ createThunk thunkDir thunkPtr
691615
692−getThunkPtr :: MonadObelisk m => FilePath -> Text -> m ThunkPtr
616+getThunkPtr :: MonadObelisk m => FilePath -> m ThunkPtr
693617getThunkPtr = getThunkPtr' True
694618
695−getThunkPtr' :: MonadObelisk m => Bool -> FilePath -> Text -> m ThunkPtr
696−getThunkPtr' checkClean thunkDir upstream = do
697− when checkClean $ ensureCleanGitRepo thunkDir True $
698− "thunk pack: thunk checkout contains unsaved modifications"
699−
700− -- Check whether there are any stashes
701− stashOutput <- readGitProcess thunkDir ["stash", "list"]
702− when checkClean $ case T.null stashOutput of
703− False -> do
704− failWith $ T.unlines $
705− [ "thunk pack: thunk checkout has stashes"
706− , "git stash list:"
707− ] ++ T.lines stashOutput
708− True -> return ()
709−
710− --Check whether all local heads are pushed
711− repoHeads <- T.lines <$> readGitProcess thunkDir ["for-each-ref", "--format=%(refname:short)", "refs/heads/"]
712− remotes <- T.lines <$> readGitProcess thunkDir ["remote"]
713− --Check that the upstream specified actually exists
714− case L.find (== upstream) remotes of
715− Nothing -> failWith $ "thunk pack: upstream " <> upstream <> " does not exist. Available upstreams are " <> T.intercalate ", " remotes
716− Just _ -> return ()
717− -- iterate over cartesian product
718− when checkClean $ forM_ repoHeads $ \hd -> do
719− [localRev] <- T.lines <$> readGitProcess thunkDir ["rev-parse", T.unpack hd]
720− forM_ remotes $ \rm -> do
721− --TODO: The error you get if a branch isn't pushed anywhere could be made more user friendly
722− [remoteMergeRev] <- fmap T.lines $ readGitProcess thunkDir
723− ["merge-base", T.unpack localRev, "remotes/" <> T.unpack rm <> "/" <> T.unpack hd]
724− case remoteMergeRev == localRev of
725− False -> failWith $ mconcat [ "thunk unpack: branch ", hd, " has not been pushed to ", rm ]
726− True -> return ()
727−
728− --We assume it's safe to pack the thunk at this point
729− [remoteUri'] <- fmap T.lines $ readGitProcess thunkDir ["config", "--get", "remote." <> T.unpack upstream <> ".url"]
730−
731− let uriParseFailure = "Could not identify git remote: " <> remoteUri'
732− mRemoteUri = parseGitUri remoteUri'
733− case mRemoteUri of
734− Nothing -> failWith uriParseFailure
735− Just remoteUri -> do
736− refs <- fmap (map (refsToTuples . T.words) . T.lines) $ readGitProcess thunkDir ["show-ref", "--head"]
737− -- safe because exactly one hash is associated with HEAD
738− let Just currentHead = fst <$> L.find ((== "HEAD") . snd) refs
739− remoteHeads = Map.fromList $ catMaybes $ fmap
740− (\(x,y) -> (,) x <$> T.stripPrefix ("refs/remotes/" <> upstream <> "/") y)
741− refs
742− localHeads = Map.fromList $ catMaybes $ fmap
743− (\(x,y) -> (,) x <$> T.stripPrefix "refs/heads/" y)
744− refs
745− currentUpstreamBranch = Map.lookup currentHead remoteHeads
746− <|> Map.lookup currentHead localHeads
747− if isGithubThunk remoteUri
748− then githubThunkPtr remoteUri currentHead currentUpstreamBranch
749− else gitThunkPtr remoteUri currentHead currentUpstreamBranch
750− where
751− refsToTuples [x, y] = (x, y)
752− refsToTuples x = error $ "thunk pack: cannot parse ref " <> show x
753− isGithubThunk u
754− | Just uriAuth <- uriAuthority u
755− = case uriScheme u of
756− "ssh:" -> uriAuth == URIAuth "git@" "github.com" ""
757− s -> s `L.elem` [ "git:", "https:", "http:" ] -- "http:" just redirects to "https:"
758− && uriRegName uriAuth == "github.com"
759− | otherwise = False
760− githubThunkPtr u commit' branch' = do
761− ["/", owner', repo'] <- return $ splitDirectories (uriPath u)
762− let owner = N (T.pack owner')
763− dropGitExtension r = fromMaybe r $ T.stripSuffix ".git" r
764− repo = N $ dropGitExtension $ T.pack repo'
765− commit = N commit'
766− branch = N <$> branch'
767− mauth <- liftIO $ getHubAuth "github.com"
768− repoResult <- liftIO $ executeRequestMaybe mauth $ repositoryR owner repo
769− repoIsPrivate <- either (liftIO . throwIO) (return . repoPrivate) repoResult
770− archiveResult <- liftIO $ executeRequestMaybe mauth $
771− archiveForR owner repo ArchiveFormatTarball (Just (untagName commit))
772− archiveUri <- either (liftIO . throwIO) return archiveResult
773− hash <- getNixSha256ForUriUnpacked archiveUri
774− return $ ThunkPtr
775− { _thunkPtr_rev = ThunkRev
776− { _thunkRev_commit = commitNameToRef commit
777− , _thunkRev_nixSha256 = hash
778− }
779− , _thunkPtr_source = ThunkSource_GitHub $ GitHubSource
780− { _gitHubSource_owner = owner
781− , _gitHubSource_repo = repo
782− , _gitHubSource_branch = branch
783− , _gitHubSource_private = repoIsPrivate
784− }
785− }
786− gitThunkPtr u commit branch' = do
787− let protocols = ["https:", "ssh:", "git:"]
788− unless (T.toLower (T.pack $ uriScheme u) `elem` protocols) $
789− failWith $ "thunk pack: obelisk currently only supports "
790− <> T.intercalate ", " protocols <> " protocols for non-GitHub remotes"
791− hash <- nixPrefetchGit u commit False
792− branch <- case branch' of
793− Nothing -> failWith "thunk pack: git thunks must track a branch"
794− Just b -> pure $ N b
795− pure $ ThunkPtr
796− { _thunkPtr_rev = ThunkRev
797− { _thunkRev_commit = commitNameToRef (N commit)
798− , _thunkRev_nixSha256 = hash
799− }
800− , _thunkPtr_source = ThunkSource_Git $ GitSource
801− { _gitSource_url = u
802− , _gitSource_branch = branch
803− , _gitSource_fetchSubmodules = False -- TODO: How do we determine if this should be true?
619+getThunkPtr' :: forall m. MonadObelisk m => Bool -> FilePath -> m ThunkPtr
620+getThunkPtr' checkClean thunkDir = do
621+ when checkClean $ ensureCleanGitRepo thunkDir True $
622+ "thunk pack: thunk checkout contains unsaved modifications"
623+
624+ -- Check whether there are any stashes
625+ stashOutput <- readGitProcess thunkDir ["stash", "list"]
626+ when checkClean $ case T.null stashOutput of
627+ False -> do
628+ failWith $ T.unlines $
629+ [ "thunk pack: thunk checkout has stashes"
630+ , "git stash list:"
631+ ] ++ T.lines stashOutput
632+ True -> return ()
633+
634+ -- Get information on all branches and their (optional) designated upstream
635+ -- correspondents
636+ (headDump :: [Text]) <- T.lines <$> readGitProcess thunkDir
637+ [ "for-each-ref"
638+ , "--format=%(refname:short) %(upstream:short) %(upstream:remotename)"
639+ , "refs/heads/"
640+ ]
641+
642+ (headInfo :: Map Text (Maybe (Text, Text)))
643+ <- fmap Map.fromList $ forM headDump $ \line -> do
644+ (branch : restOfLine) <- pure $ T.words line
645+ mUpstream <- case restOfLine of
646+ [] -> pure Nothing
647+ [u, r] -> pure $ Just (u, r)
648+ (_:_) -> failWith "git for-each-ref invalid output"
649+ pure (branch, mUpstream)
650+
651+ putLog Debug $ "branches: " <> T.pack (show headInfo)
652+
653+ let errorMap :: Map Text ()
654+ headUpstream :: Map Text (Text, Text)
655+ (errorMap, headUpstream) = flip Map.mapEither headInfo $ \case
656+ Nothing -> Left ()
657+ Just b -> Right b
658+
659+ putLog Debug $ "branches with upstream branch set: " <> T.pack (show headUpstream)
660+
661+ -- Check that every branch has a remote equivalent
662+ when checkClean $ do
663+ let untrackedBranches = Map.keys errorMap
664+ when (not $ L.null untrackedBranches) $ failWith $ T.unlines $
665+ [ "thunk pack: Certain branches in the thunk have no upstream branch \
666+ \set. This means don't know to check whether all your work is \
667+ \saved. The offending branches are:"
668+ , ""
669+ , T.unwords untrackedBranches
670+ , ""
671+ , "To fix this, you probably want to do:"
672+ , ""
673+ ] ++
674+ ((\branch -> "git push -u origin " <> branch) <$> untrackedBranches) ++
675+ [ ""
676+ , "These will push the branches to the default remote under the same \
677+ \name, and (thanks to the `-u`) remember that choice so you don't \
678+ \get this error again."
679+ ]
680+
681+ -- loosely by https://stackoverflow.com/questions/7773939/show-git-ahead-and-behind-info-for-all-branches-including-remotes
682+ stats <- iforM headUpstream $ \branch (upstream, _remote) -> do
683+ (stat :: [Text]) <- T.lines <$> readGitProcess thunkDir
684+ [ "rev-list", "--left-right"
685+ , T.unpack branch <> "..." <> T.unpack upstream
686+ ]
687+ let ahead = length $ [ () | Just ('<', _) <- T.uncons <$> stat ]
688+ behind = length $ [ () | Just ('>', _) <- T.uncons <$> stat ]
689+ pure (upstream, (ahead, behind))
690+
691+ -- Those branches which have commits ahead of, i.e. not on, the upstream
692+ -- branch. Purely being behind is fine.
693+ let nonGood = Map.filter ((/= 0) . fst . snd) stats
694+
695+ when (not $ Map.null nonGood) $ failWith $ T.unlines $
696+ [ "thunk pack: Certain branches in the thunk have commits not yet pushed upstream:"
697+ , ""
698+ ] ++
699+ (flip map (Map.toList nonGood) $ \(branch, (upstream, (ahead, behind))) -> mconcat
700+ [" ", branch, " ahead: ", T.pack (show ahead), " behind: ", T.pack (show behind), " remote branch ", upstream]) ++
701+ [ ""
702+ , "Please push these upstream and try again. (Or just fetch, if they are somehow \
703+ \pushed but this repo's remote tracking branches don't know it.)"
704+ ]
705+
706+ -- We assume it's safe to pack the thunk at this point
707+ putLog Informational $ "All changes safe in git remotes. OK to pack thunk."
708+
709+ -- Get current branch ``
710+ mCurrentBranch <- listToMaybe
711+ <$> T.lines
712+ <$> readGitProcess thunkDir ["rev-parse", "--abbrev-ref", "HEAD"]
713+
714+ let remote = maybe "origin" snd $ flip Map.lookup headUpstream =<< mCurrentBranch
715+
716+ [remoteUri'] <- fmap T.lines $ readGitProcess thunkDir
717+ [ "config"
718+ , "--get"
719+ , "remote." <> T.unpack remote <> ".url"
720+ ]
721+
722+ remoteUri <- case parseGitUri remoteUri' of
723+ Nothing -> failWith $ "Could not identify git remote: " <> remoteUri'
724+ Just uri -> pure uri
725+ uriThunkPtr remoteUri mCurrentBranch
726+
727+-- | Get the latest revision available from the given source
728+getLatestRev :: MonadObelisk m => ThunkSource -> m ThunkRev
729+getLatestRev os = do
730+ let gitS = case os of
731+ ThunkSource_GitHub s -> forgetGithub False s
732+ ThunkSource_Git s -> s
733+ (_, commit) <- gitGetCommitBranch (_gitSource_url gitS) (untagName <$> _gitSource_branch gitS)
734+ case os of
735+ ThunkSource_GitHub s -> githubThunkRev s commit
736+ ThunkSource_Git s -> gitThunkRev s commit
737+
738+-- | Convert a URI to a thunk
739+--
740+-- If the URL is a github URL, we try to just download an archive for
741+-- performance. If that doesn't work (e.g. authentication issue), we fall back
742+-- on just doing things the normal way for git repos in general, and save it as
743+-- a regular git thunk.
744+uriThunkPtr :: MonadObelisk m => URI -> Maybe Text -> m ThunkPtr
745+uriThunkPtr uri mbranch = do
746+ (_, commit) <- gitGetCommitBranch uri mbranch
747+ (src, rev) <- case uriToThunkSource uri mbranch of
748+ ThunkSource_GitHub s -> do
749+ rev <- runExceptT $ githubThunkRev s commit
750+ case rev of
751+ Right r -> pure (ThunkSource_GitHub s, r)
752+ Left e -> do
753+ putLog Warning $ "\
754+\Failed to fetch archive from GitHub. This is probably a private repo. \
755+\Falling back on normal fetchgit. Original failure:\n\n"
756+ errorToWarning e
757+ let s' = forgetGithub True s
758+ (,) (ThunkSource_Git s') <$> gitThunkRev s' commit
759+ ThunkSource_Git s -> (,) (ThunkSource_Git s) <$> gitThunkRev s commit
760+ pure $ ThunkPtr
761+ { _thunkPtr_rev = rev
762+ , _thunkPtr_source = src
763+ }
764+
765+-- | N.B. Cannot infer all fields.
766+--
767+-- If the thunk is a GitHub thunk and fails, we do *not* fall back like with
768+-- `uriThunkPtr`. Unlike a plain URL, a thunk src explicitly states which method
769+-- should be employed, and so we respect that.
770+uriToThunkSource :: URI -> Maybe Text -> ThunkSource
771+uriToThunkSource u
772+ | Right uriAuth <- uriAuthority u
773+ , Just scheme <- unRText <$> uriScheme u
774+ , case scheme of
775+ "ssh" -> uriAuth == Authority
776+ { authUserInfo = Just $ UserInfo (fromRight' $ mkUsername "git") Nothing
777+ , authHost = fromRight' $ mkHost "github.com"
778+ , authPort = Nothing
804779 }
805− }
780+ s -> s `L.elem` [ "git", "https", "http" ] -- "http:" just redirects to "https:"
781+ && unRText (authHost uriAuth) == "github.com"
782+ , Just (_, owner :| [repoish]) <- uriPath u
783+ = \mbranch -> ThunkSource_GitHub $ GitHubSource
784+ { _gitHubSource_owner = N $ unRText owner
785+ , _gitHubSource_repo = N $ let
786+ repoish' = unRText repoish
787+ in case T.stripSuffix ".git" repoish' of
788+ Just repo -> repo
789+ Nothing -> repoish'
790+ , _gitHubSource_branch = N <$> mbranch
791+ }
792+
793+ | otherwise = \mbranch -> ThunkSource_Git $ GitSource
794+ { _gitSource_url = u
795+ , _gitSource_branch = N <$> mbranch
796+ , _gitSource_fetchSubmodules = False -- TODO: How do we determine if this should be true?
797+ }
798+
799+-- Funny signature indicates no effects depend on the optional branch name.
800+githubThunkRev
801+ :: forall m
802+ . MonadObelisk m
803+ => GitHubSource
804+ -> Text
805+ -> m ThunkRev
806+githubThunkRev s commit = do
807+ owner <- forcePP $ _gitHubSource_owner s
808+ repo <- forcePP $ _gitHubSource_repo s
809+ revTarball <- mkPathPiece $ commit <> ".tar.gz"
810+ let archiveUri = URI
811+ { uriScheme = Just $ fromRight' $ mkScheme "https"
812+ , uriAuthority = Right $ Authority
813+ { authUserInfo = Nothing
814+ , authHost = fromRight' $ mkHost "github.com"
815+ , authPort = Nothing
816+ }
817+ , uriPath = Just ( False
818+ , owner :| [ repo, fromRight' $ mkPathPiece "archive", revTarball ]
819+ )
820+ , uriQuery = []
821+ , uriFragment = Nothing
822+ }
823+ hash <- getNixSha256ForUriUnpacked archiveUri
824+ putLog Debug $ "Nix sha256 is " <> hash
825+ return $ ThunkRev
826+ { _thunkRev_commit = commitNameToRef $ N commit
827+ , _thunkRev_nixSha256 = hash
828+ }
829+ where
830+ forcePP :: Name entity -> m (RText 'PathPiece)
831+ forcePP = mkPathPiece . untagName
832+
833+gitThunkRev
834+ :: MonadObelisk m
835+ => GitSource
836+ -> Text
837+ -> m ThunkRev
838+gitThunkRev s commit = do
839+ let u = _gitSource_url s
840+ protocols = ["https", "ssh", "git"]
841+ Just scheme <- pure $ unRText <$> uriScheme u
842+ unless (T.toLower scheme `elem` protocols) $
843+ failWith $ "obelisk currently only supports "
844+ <> T.intercalate ", " protocols <> " protocols for non-GitHub remotes"
845+ hash <- nixPrefetchGit u commit $ _gitSource_fetchSubmodules s
846+ putLog Informational $ "Nix sha256 is " <> hash
847+ pure $ ThunkRev
848+ { _thunkRev_commit = commitNameToRef (N commit)
849+ , _thunkRev_nixSha256 = hash
850+ }
851+
852+-- | Given the URI to a git remote, and an optional branch name, return the name
853+-- of the branch along with the hash of the commit at tip of that branch.
854+--
855+-- If the branch name is passed in, it is returned exactly as-is. If it is not
856+-- passed it, the default branch of the repo is used instead.
857+gitGetCommitBranch
858+ :: MonadObelisk m => URI -> Maybe Text -> m (Text, CommitId)
859+gitGetCommitBranch uri mbranch = withExitFailMessage ("Failure for git remote " <> uriMsg) $ do
860+ bothMaps <- gitLsRemote
861+ (T.unpack $ render uri)
862+ (GitRef_Branch <$> mbranch)
863+ branch <- case mbranch of
864+ Nothing -> withExitFailMessage "Failed to find default branch" $ do
865+ b <- rethrowE $ gitLookupDefaultBranch bothMaps
866+ putLog Debug $ "Default branch for remote repo " <> uriMsg <> " is " <> b
867+ pure b
868+ Just b -> pure b
869+ commit <- rethrowE $ gitLookupCommitForRef bothMaps (GitRef_Branch branch)
870+ putLog Informational $ "Latest commit in branch " <> branch
871+ <> " from remote repo " <> uriMsg
872+ <> " is " <> commit
873+ pure (branch, commit)
874+ where
875+ rethrowE = either failWith pure
876+ uriMsg = render uri
806877
807878parseGitUri :: Text -> Maybe URI
808−parseGitUri x = parseURIReference (T.unpack x) <|> parseSshShorthand x
879+parseGitUri x = parseAbsoluteURI x <|> parseSshShorthand x
880+
881+parseAbsoluteURI :: Text -> Maybe URI
882+parseAbsoluteURI uri = do
883+ parsedUri <- mkURI uri
884+ guard $ isPathAbsolute parsedUri
885+ pure $ parsedUri
809886
810887parseSshShorthand :: Text -> Maybe URI
811888parseSshShorthand uri = do
@@ -820,4 +897,4 @@ parseSshShorthand uri = do
820897 -- This check is used to disambiguate a filepath containing a colon from shorthand
821898 guard $ isNothing (T.findIndex (=='/') authAndHostname)
822899 && not (T.null colonAndPath)
823− parseURI $ T.unpack properUri
900+ mkURI properUri