@@ -47,6 +47,7 @@ import qualified Data.Aeson as Aeson
4747import Data.Aeson.Encode.Pretty
4848import qualified Data.Aeson.Types as Aeson
4949import qualified Data.ByteString.Lazy as LBS
50+import Data.Containers.ListUtils (nubOrd)
5051import Data.Default
5152import Data.Either.Combinators (fromRight', rightToMaybe)
5253import Data.Git.Ref (Ref)
@@ -69,6 +70,7 @@ import GitHub
6970import GitHub.Data.Name
7071import Obelisk.Command.Nix
7172import System.Directory
73+import System.Exit
7274import System.FilePath
7375import System.IO.Error
7476import System.IO.Temp
@@ -119,7 +121,7 @@ data GitHubSource = GitHubSource
119121 }
120122 deriving (Show, Eq, Ord)
121123
122−newtype GitUri = GitUri URI.URI deriving (Eq, Ord, Show)
124+newtype GitUri = GitUri { unGitUri :: URI.URI } deriving (Eq, Ord, Show)
123125
124126gitUriToText :: GitUri -> Text
125127gitUriToText (GitUri uri)
@@ -443,7 +445,7 @@ updateThunkToLatest (ThunkUpdateConfig mBranch thunkConfig) target = withSpinner
443445
444446setThunk :: MonadObelisk m => ThunkConfig -> FilePath -> GitSource -> String -> m ()
445447setThunk thunkConfig target gs branch = do
446− newThunkPtr <- uriThunkPtr (_gitSource_url gs) (Just $ T.pack branch) Nothing
448+ newThunkPtr <- uriThunkPtr (_gitSource_url gs) (_thunkConfig_private thunkConfig) (Just $ T.pack branch) Nothing
447449 overwriteThunk target newThunkPtr
448450 updateThunkToLatest (ThunkUpdateConfig Nothing thunkConfig) target
449451
@@ -699,7 +701,7 @@ packThunk' noTrail (ThunkPackConfig force thunkConfig) thunkDir = checkThunkDire
699701 Right (ThunkData_Checkout _) -> do
700702 withSpinner' ("Packing thunk " <> T.pack thunkDir)
701703 (finalMsg noTrail $ const $ "Packed thunk " <> T.pack thunkDir) $ do
702− thunkPtr <- modifyThunkPtrByConfig thunkConfig <$> getThunkPtr (not force) thunkDir
704+ thunkPtr <- modifyThunkPtrByConfig thunkConfig <$> getThunkPtr (not force) thunkDir (_thunkConfig_private thunkConfig)
703705 callProcessAndLogOutput (Debug, Error) $ proc "rm" ["-rf", thunkDir]
704706 liftIO $ createThunk thunkDir thunkPtr
705707 pure thunkPtr
@@ -712,8 +714,8 @@ modifyThunkPtrByConfig (ThunkConfig markPrivate') ptr = case markPrivate' of
712714 ThunkSource_GitHub s -> ThunkSource_GitHub $ s { _gitHubSource_private = markPrivate }
713715 }
714716
715−getThunkPtr :: forall m. MonadObelisk m => Bool -> FilePath -> m ThunkPtr
716−getThunkPtr checkClean thunkDir = do
717+getThunkPtr :: forall m. MonadObelisk m => Bool -> FilePath -> Maybe Bool -> m ThunkPtr
718+getThunkPtr checkClean thunkDir mPrivate = do
717719 when checkClean $ ensureCleanGitRepo thunkDir True
718720 "thunk pack: thunk checkout contains unsaved modifications"
719721
@@ -727,7 +729,7 @@ getThunkPtr checkClean thunkDir = do
727729 ] ++ T.lines stashOutput
728730 True -> return ()
729731
730− -- Get current branch ``
732+ -- Get current branch
731733 (mCurrentBranch, mCurrentCommit) <- do
732734 b <- listToMaybe
733735 <$> T.lines
@@ -829,7 +831,7 @@ getThunkPtr checkClean thunkDir = do
829831 remoteUri <- case parseGitUri remoteUri' of
830832 Nothing -> failWith $ "Could not identify git remote: " <> remoteUri'
831833 Just uri -> pure uri
832− uriThunkPtr remoteUri mCurrentBranch mCurrentCommit
834+ uriThunkPtr remoteUri mPrivate mCurrentBranch mCurrentCommit
833835
834836-- | Get the latest revision available from the given source
835837getLatestRev :: MonadObelisk m => ThunkSource -> m ThunkRev
@@ -848,12 +850,12 @@ getLatestRev os = do
848850-- performance. If that doesn't work (e.g. authentication issue), we fall back
849851-- on just doing things the normal way for git repos in general, and save it as
850852-- a regular git thunk.
851−uriThunkPtr :: MonadObelisk m => GitUri -> Maybe Text -> Maybe Text -> m ThunkPtr
852−uriThunkPtr uri mbranch mcommit = do
853+uriThunkPtr :: MonadObelisk m => GitUri -> Maybe Bool -> Maybe Text -> Maybe Text -> m ThunkPtr
854+uriThunkPtr uri mPrivate mbranch mcommit = do
853855 commit <- case mcommit of
854856 Nothing -> gitGetCommitBranch uri mbranch >>= return . snd
855857 (Just c) -> return c
856− (src, rev) <- case uriToThunkSource uri mbranch of
858+ (src, rev) <- uriToThunkSource uri mPrivate mbranch >>= \case
857859 ThunkSource_GitHub s -> do
858860 rev <- runExceptT $ githubThunkRev s commit
859861 case rev of
@@ -876,8 +878,8 @@ uriThunkPtr uri mbranch mcommit = do
876878-- If the thunk is a GitHub thunk and fails, we do *not* fall back like with
877879-- `uriThunkPtr`. Unlike a plain URL, a thunk src explicitly states which method
878880-- should be employed, and so we respect that.
879−uriToThunkSource :: GitUri -> Maybe Text -> ThunkSource
880−uriToThunkSource (GitUri u)
881+uriToThunkSource :: MonadObelisk m => GitUri -> Maybe Bool -> Maybe Text -> m ThunkSource
882+uriToThunkSource (GitUri u) mPrivate
881883 | Right uriAuth <- URI.uriAuthority u
882884 , Just scheme <- URI.unRText <$> URI.uriScheme u
883885 , case scheme of
@@ -889,21 +891,53 @@ uriToThunkSource (GitUri u)
889891 s -> s `L.elem` [ "git", "https", "http" ] -- "http:" just redirects to "https:"
890892 && URI.unRText (URI.authHost uriAuth) == "github.com"
891893 , Just (_, owner :| [repoish]) <- URI.uriPath u
892− = \mbranch -> ThunkSource_GitHub $ GitHubSource
893− { _gitHubSource_owner = N $ URI.unRText owner
894− , _gitHubSource_repo = N $ let
895− repoish' = URI.unRText repoish
896− in fromMaybe repoish' $ T.stripSuffix ".git" repoish'
897− , _gitHubSource_branch = N <$> mbranch
898− , _gitHubSource_private = False -- TODO: Can we try something to infer this?
899− }
894+ = \mbranch -> do
895+ isPrivate <- getIsPrivate
896+ pure $ ThunkSource_GitHub $ GitHubSource
897+ { _gitHubSource_owner = N $ URI.unRText owner
898+ , _gitHubSource_repo = N $ let
899+ repoish' = URI.unRText repoish
900+ in fromMaybe repoish' $ T.stripSuffix ".git" repoish'
901+ , _gitHubSource_branch = N <$> mbranch
902+ , _gitHubSource_private = isPrivate
903+ }
900904
901− | otherwise = \mbranch -> ThunkSource_Git $ GitSource
902− { _gitSource_url = GitUri u
903− , _gitSource_branch = N <$> mbranch
904− , _gitSource_fetchSubmodules = False -- TODO: How do we determine if this should be true?
905− , _gitSource_private = False -- TODO: Can we try something to infer this?
906− }
905+ | otherwise = \mbranch -> do
906+ isPrivate <- getIsPrivate
907+ pure $ ThunkSource_Git $ GitSource
908+ { _gitSource_url = GitUri u
909+ , _gitSource_branch = N <$> mbranch
910+ , _gitSource_fetchSubmodules = False -- TODO: How do we determine if this should be true?
911+ , _gitSource_private = isPrivate
912+ }
913+ where
914+ getIsPrivate = maybe (guessGitRepoIsPrivate $ GitUri u) pure mPrivate
915+
916+guessGitRepoIsPrivate :: MonadObelisk m => GitUri -> m Bool
917+guessGitRepoIsPrivate uri = flip fix urisToTry $ \loop -> \case
918+ [] -> pure True
919+ uriAttempt:xs -> do
920+ result <- readCreateProcessWithExitCode $
921+ isolateGitProc $
922+ gitProcNoRepo
923+ [ "ls-remote"
924+ , "--quiet"
925+ , "--exit-code"
926+ , "--symref"
927+ , T.unpack $ gitUriToText uriAttempt
928+ ]
929+ case result of
930+ (ExitSuccess, _, _) -> pure False -- Must be a public repo
931+ _ -> loop xs
932+ where
933+ urisToTry = nubOrd $
934+ -- Include the original URI if it isn't using SSH because SSH will certainly fail.
935+ [uri | fmap URI.unRText (URI.uriScheme (unGitUri uri)) /= Just "ssh"] <>
936+ [changeScheme "https" uri, changeScheme "http" uri, changeScheme "git" uri]
937+ changeScheme scheme (GitUri u) = GitUri $ u
938+ { URI.uriScheme = URI.mkScheme scheme
939+ , URI.uriAuthority = (\x -> x { URI.authUserInfo = Nothing }) <$> URI.uriAuthority u
940+ }
907941
908942-- Funny signature indicates no effects depend on the optional branch name.
909943githubThunkRev
@@ -963,6 +997,7 @@ gitThunkRev s commit = do
963997--
964998-- If the branch name is passed in, it is returned exactly as-is. If it is not
965999-- passed it, the default branch of the repo is used instead.
1000+
9661001gitGetCommitBranch
9671002 :: MonadObelisk m => GitUri -> Maybe Text -> m (Text, CommitId)
9681003gitGetCommitBranch uri mbranch = withExitFailMessage ("Failure for git remote " <> uriMsg) $ do