@@ -8,25 +8,31 @@
88{-# LANGUAGE ScopedTypeVariables #-}
99{-# LANGUAGE TypeApplications #-}
1010module Obelisk.Command.Thunk
11− ( ThunkPtr (..)
11+ ( GitHubSource (..)
12+ , GitUri (..)
13+ , ReadThunkError (..)
14+ , ThunkConfig (..)
15+ , ThunkData (..)
16+ , ThunkPackConfig (..)
17+ , ThunkPtr (..)
1218 , ThunkRev (..)
1319 , ThunkSource (..)
14− , ThunkData (..)
15− , ReadThunkError (..)
16− , GitHubSource (..)
17− , getThunkGitBranch
18− , getLatestRev
19− , updateThunkToLatest
20+ , ThunkUpdateConfig (..)
21+ , attrCacheFileName
2022 , createThunk
2123 , createThunkWithLatest
24+ , getLatestRev
25+ , getThunkGitBranch
26+ , getThunkPtr
27+ , gitUriToText
2228 , nixBuildAttrWithCache
2329 , nixBuildThunkAttrWithCache
24− , unpackThunk
2530 , packThunk
31+ , parseGitUri
2632 , readThunk
33+ , unpackThunk
2734 , updateThunk
28− , getThunkPtr
29− , parseGitUri
35+ , updateThunkToLatest
3036 , uriThunkPtr
3137 ) where
3238
@@ -42,6 +48,7 @@ import qualified Data.Aeson as Aeson
4248import Data.Aeson.Encode.Pretty
4349import qualified Data.Aeson.Types as Aeson
4450import qualified Data.ByteString.Lazy as LBS
51+import Data.Containers.ListUtils (nubOrd)
4552import Data.Default
4653import Data.Either.Combinators (fromRight', rightToMaybe)
4754import Data.Git.Ref (Ref)
@@ -64,12 +71,12 @@ import GitHub
6471import GitHub.Data.Name
6572import Obelisk.Command.Nix
6673import System.Directory
74+import System.Exit
6775import System.FilePath
6876import System.IO.Error
6977import System.IO.Temp
7078import System.Posix (getSymbolicLinkStatus, modificationTime)
71−import System.Process (proc)
72−import Text.URI
79+import qualified Text.URI as URI
7380
7481import Obelisk.App (MonadObelisk)
7582import Obelisk.CliApp
@@ -111,37 +118,63 @@ data GitHubSource = GitHubSource
111118 { _gitHubSource_owner :: Name Owner
112119 , _gitHubSource_repo :: Name Repo
113120 , _gitHubSource_branch :: Maybe (Name Branch)
121+ , _gitHubSource_private :: Bool
114122 }
115123 deriving (Show, Eq, Ord)
116124
125+newtype GitUri = GitUri { unGitUri :: URI.URI } deriving (Eq, Ord, Show)
126+
127+gitUriToText :: GitUri -> Text
128+gitUriToText (GitUri uri)
129+ | (T.toLower . URI.unRText <$> URI.uriScheme uri) == Just "file"
130+ , Just (_, path) <- URI.uriPath uri
131+ = "/" <> T.intercalate "/" (map URI.unRText $ NonEmpty.toList path)
132+ | otherwise = URI.render uri
133+
117134data GitSource = GitSource
118− { _gitSource_url :: URI
135+ { _gitSource_url :: GitUri
119136 , _gitSource_branch :: Maybe (Name Branch)
120137 , _gitSource_fetchSubmodules :: Bool
138+ , _gitSource_private :: Bool
121139 }
122140 deriving (Show, Eq, Ord)
123141
142+newtype ThunkConfig = ThunkConfig
143+ { _thunkConfig_private :: Maybe Bool
144+ } deriving Show
145+
146+data ThunkUpdateConfig = ThunkUpdateConfig
147+ { _thunkUpdateConfig_branch :: Maybe String
148+ , _thunkUpdateConfig_config :: ThunkConfig
149+ } deriving Show
150+
151+data ThunkPackConfig = ThunkPackConfig
152+ { _thunkPackConfig_force :: Bool
153+ , _thunkPackConfig_config :: ThunkConfig
154+ } deriving Show
155+
124156-- | Convert a GitHub source to a regular Git source. Assumes no submodules.
125157forgetGithub :: Bool -> GitHubSource -> GitSource
126158forgetGithub useSsh s = GitSource
127− { _gitSource_url = URI
128− { uriScheme = Just $ fromRight' $ mkScheme $ if useSsh then "ssh" else "https"
129− , uriAuthority = Right $ Authority
130− { authUserInfo = UserInfo (fromRight' $ mkUsername "git") Nothing
159+ { _gitSource_url = GitUri $ URI.URI
160+ { URI.uriScheme = Just $ fromRight' $ URI.mkScheme $ if useSsh then "ssh" else "https"
161+ , URI.uriAuthority = Right $ URI.Authority
162+ { URI.authUserInfo = URI.UserInfo (fromRight' $ URI.mkUsername "git") Nothing
131163 <$ guard useSsh
132− , authHost = fromRight' $ mkHost "github.com"
133− , authPort = Nothing
164+ , URI.authHost = fromRight' $ URI.mkHost "github.com"
165+ , URI.authPort = Nothing
134166 }
135− , uriPath = Just ( False
136− , fromRight' . mkPathPiece <$>
167+ , URI.uriPath = Just ( False
168+ , fromRight' . URI.mkPathPiece <$>
137169 untagName (_gitHubSource_owner s)
138170 :| [ untagName (_gitHubSource_repo s) <> ".git" ]
139171 )
140− , uriQuery = []
141− , uriFragment = Nothing
172+ , URI.uriQuery = []
173+ , URI.uriFragment = Nothing
142174 }
143175 , _gitSource_branch = _gitHubSource_branch s
144176 , _gitSource_fetchSubmodules = False
177+ , _gitSource_private = _gitHubSource_private s
145178 }
146179
147180getThunkGitBranch :: ThunkPtr -> Maybe Text
@@ -155,20 +188,20 @@ commitNameToRef (N c) = Ref.fromHex $ encodeUtf8 c
155188-- TODO: Use spinner here.
156189getNixSha256ForUriUnpacked
157190 :: MonadObelisk m
158− => URI
191+ => GitUri
159192 -> m NixSha256
160193getNixSha256ForUriUnpacked uri =
161− withExitFailMessage ("nix-prefetch-url: Failed to determine sha256 hash of URL " <> render uri) $ do
194+ withExitFailMessage ("nix-prefetch-url: Failed to determine sha256 hash of URL " <> gitUriToText uri) $ do
162195 [hash] <- fmap T.lines $ readProcessAndLogOutput (Debug, Debug) $
163− proc "nix-prefetch-url" ["--unpack" , "--type" , "sha256" , T.unpack $ render uri]
196+ proc "nix-prefetch-url" ["--unpack", "--type", "sha256", T.unpack $ gitUriToText uri]
164197 pure hash
165198
166−nixPrefetchGit :: MonadObelisk m => URI -> Text -> Bool -> m NixSha256
199+nixPrefetchGit :: MonadObelisk m => GitUri -> Text -> Bool -> m NixSha256
167200nixPrefetchGit uri rev fetchSubmodules =
168− withExitFailMessage ("nix-prefetch-git: Failed to determine sha256 hash of Git repo " <> render uri <> " at " <> rev) $ do
201+ withExitFailMessage ("nix-prefetch-git: Failed to determine sha256 hash of Git repo " <> gitUriToText uri <> " at " <> rev) $ do
169202 out <- readProcessAndLogStderr Debug $
170203 proc "nix-prefetch-git" $ filter (/="")
171− [ "--url", T.unpack $ render uri
204+ [ "--url", T.unpack $ gitUriToText uri
172205 , "--rev", T.unpack rev
173206 , if fetchSubmodules then "--fetch-submodules" else ""
174207 , "--quiet"
@@ -199,6 +232,9 @@ readThunk thunkDir = do
199232 False -> return $ return Nothing
200233 False -> liftIO $ fmap ThunkData_Packed <$> readPackedThunk thunkDir
201234
235+attrCacheFileName :: FilePath
236+attrCacheFileName = ".attr-cache"
237+
202238data ThunkType = ThunkType
203239 { _thunkType_loader :: FilePath
204240 , _thunkType_json :: FilePath
@@ -211,7 +247,7 @@ gitHubThunkType :: ThunkType
211247gitHubThunkType = ThunkType
212248 { _thunkType_loader = "default.nix"
213249 , _thunkType_json = "github.json"
214− , _thunkType_optional = Set.fromList [".attr-cache"]
250+ , _thunkType_optional = Set.fromList [attrCacheFileName]
215251 , _thunkType_loaderVersions = gitHubStandaloneLoaders
216252 , _thunkType_parser = parseThunkPtr $ \v ->
217253 ThunkSource_GitHub <$> parseGitHubSource v <|> ThunkSource_Git <$> parseGitSource v
@@ -221,7 +257,7 @@ gitThunkType :: ThunkType
221257gitThunkType = ThunkType
222258 { _thunkType_loader = "default.nix"
223259 , _thunkType_json = "git.json"
224− , _thunkType_optional = Set.fromList [".attr-cache"]
260+ , _thunkType_optional = Set.fromList [attrCacheFileName]
225261 , _thunkType_loaderVersions = plainGitStandaloneLoaders
226262 , _thunkType_parser = parseThunkPtr $ fmap ThunkSource_Git . parseGitSource
227263 }
@@ -286,10 +322,12 @@ parseGitHubSource v = do
286322 owner <- v Aeson..: "owner"
287323 repo <- v Aeson..: "repo"
288324 branch <- v Aeson..:! "branch"
325+ private <- v Aeson..:? "private"
289326 pure $ GitHubSource
290327 { _gitHubSource_owner = owner
291328 , _gitHubSource_repo = repo
292329 , _gitHubSource_branch = branch
330+ , _gitHubSource_private = fromMaybe False private
293331 }
294332
295333parseGitSource :: Aeson.Object -> Aeson.Parser GitSource
@@ -297,10 +335,12 @@ parseGitSource v = do
297335 Just url <- parseGitUri <$> v Aeson..: "url"
298336 branch <- v Aeson..:! "branch"
299337 fetchSubmodules <- v Aeson..:! "fetchSubmodules"
338+ private <- v Aeson..:? "private"
300339 pure $ GitSource
301340 { _gitSource_url = url
302341 , _gitSource_branch = branch
303342 , _gitSource_fetchSubmodules = fromMaybe False fetchSubmodules
343+ , _gitSource_private = fromMaybe False private
304344 }
305345
306346overwriteThunk :: MonadObelisk m => FilePath -> ThunkPtr -> m ()
@@ -327,13 +367,15 @@ encodeThunkPtrData (ThunkPtr rev src) = case src of
327367 , ("branch" .=) <$> _gitHubSource_branch s
328368 , Just $ "rev" .= Ref.toHexString (_thunkRev_commit rev)
329369 , Just $ "sha256" .= _thunkRev_nixSha256 rev
370+ , Just $ "private" .= _gitHubSource_private s
330371 ]
331372 ThunkSource_Git s -> encodePretty' plainGitCfg $ Aeson.object $ catMaybes
332− [ Just $ "url" .= render (_gitSource_url s)
373+ [ Just $ "url" .= gitUriToText (_gitSource_url s)
333374 , Just $ "rev" .= Ref.toHexString (_thunkRev_commit rev)
334375 , ("branch" .=) <$> _gitSource_branch s
335376 , Just $ "sha256" .= _thunkRev_nixSha256 rev
336377 , Just $ "fetchSubmodules" .= _gitSource_fetchSubmodules s
378+ , Just $ "private" .= _gitSource_private s
337379 ]
338380 where
339381 githubCfg = defConfig
@@ -354,6 +396,7 @@ encodeThunkPtrData (ThunkPtr rev src) = case src of
354396 [ "url"
355397 , "rev"
356398 , "sha256"
399+ , "private"
357400 , "fetchSubmodules"
358401 ] <> compare
359402 , confTrailingNewline = True
@@ -361,7 +404,7 @@ encodeThunkPtrData (ThunkPtr rev src) = case src of
361404
362405createThunk :: MonadIO m => FilePath -> ThunkPtr -> m ()
363406createThunk target thunk = liftIO $ do
364− createDirectoryIfMissing True (target </> ".attr-cache")
407+ createDirectoryIfMissing True (target </> attrCacheFileName)
365408 T.writeFile (target </> "default.nix") (thunkPtrLoader thunk)
366409 let
367410 jsonFileName = case _thunkPtr_source thunk of
@@ -377,8 +420,8 @@ createThunkWithLatest target s = do
377420 , _thunkPtr_rev = rev
378421 }
379422
380−updateThunkToLatest :: MonadObelisk m => FilePath -> Maybe String -> m ()
381−updateThunkToLatest target mBranch = withSpinner' ("Updating thunk " <> T.pack target <> " to latest") (pure $ const $ "Thunk " <> T.pack target <> " updated to latest") $ do
423+updateThunkToLatest :: MonadObelisk m => ThunkUpdateConfig -> FilePath -> m ()
424+updateThunkToLatest (ThunkUpdateConfig mBranch thunkConfig) target = withSpinner' ("Updating thunk " <> T.pack target <> " to latest") (pure $ const $ "Thunk " <> T.pack target <> " updated to latest") $ do
382425 checkThunkDirectory "ob thunk update directory cannot be '.'" target
383426 -- check to see if thunk should be updated to a specific branch or just update it's current branch
384427 case mBranch of
@@ -390,7 +433,7 @@ updateThunkToLatest target mBranch = withSpinner' ("Updating thunk " <> T.pack t
390433 ThunkData_Checkout _ -> failWith "cannot update an unpacked thunk"
391434 let src = _thunkPtr_source ptr
392435 rev <- getLatestRev src
393− overwriteThunk overwrite $ ThunkPtr
436+ overwriteThunk overwrite $ modifyThunkPtrByConfig thunkConfig $ ThunkPtr
394437 { _thunkPtr_source = src
395438 , _thunkPtr_rev = rev
396439 }
@@ -398,24 +441,25 @@ updateThunkToLatest target mBranch = withSpinner' ("Updating thunk " <> T.pack t
398441 Left err -> failWith $ T.pack $ "thunk update: " <> show err
399442 Right c -> case c of
400443 ThunkData_Packed t -> case _thunkPtr_source t of
401− ThunkSource_Git tsg -> setThunk target tsg branch
444+ ThunkSource_Git tsg -> setThunk thunkConfig target tsg branch
402445 ThunkSource_GitHub tsgh -> do
403446 let tsg = forgetGithub False tsgh
404− setThunk target tsg branch
405− ThunkData_Checkout _ -> failWith $ T.pack $ "thunk located at " <> (show target) <> " is unpacked. Use ob thunk pack on the desired directory and then try ob thunk update again."
447+ setThunk thunkConfig target tsg branch
448+ ThunkData_Checkout _ -> failWith $ T.pack $ "thunk located at " <> show target <> " is unpacked. Use ob thunk pack on the desired directory and then try ob thunk update again."
406449
407−setThunk :: MonadObelisk m => FilePath -> GitSource -> String -> m ()
408−setThunk target gs branch = do
409− newThunkPtr <- uriThunkPtr (_gitSource_url gs) (Just $ T.pack branch) Nothing
450+setThunk :: MonadObelisk m => ThunkConfig -> FilePath -> GitSource -> String -> m ()
451+setThunk thunkConfig target gs branch = do
452+ newThunkPtr <- uriThunkPtr (_gitSource_url gs) (_thunkConfig_private thunkConfig) (Just $ T.pack branch) Nothing
410453 overwriteThunk target newThunkPtr
411− updateThunkToLatest target Nothing
454+ updateThunkToLatest (ThunkUpdateConfig Nothing thunkConfig) target
412455
413456-- | All recognized github standalone loaders, ordered from newest to oldest.
414457-- This tool will only ever produce the newest one when it writes a thunk.
415458gitHubStandaloneLoaders :: NonEmpty Text
416459gitHubStandaloneLoaders =
417− gitHubStandaloneLoaderV2 :|
460+ gitHubStandaloneLoaderV4 :|
418461 [ gitHubStandaloneLoaderV3
462+ , gitHubStandaloneLoaderV2
419463 , gitHubStandaloneLoaderV1
420464 ]
421465
@@ -455,10 +499,24 @@ gitHubStandaloneLoaderV3 = T.unlines
455499 , "in import (fetch (builtins.fromJSON (builtins.readFile ./github.json)))"
456500 ]
457501
502+gitHubStandaloneLoaderV4 :: Text
503+gitHubStandaloneLoaderV4 = T.unlines
504+ [ "# DO NOT HAND-EDIT THIS FILE"
505+ , "let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }:"
506+ , " if !fetchSubmodules && !private then builtins.fetchTarball {"
507+ , " url = \"https://github.com/${owner}/${repo}/archive/${rev}.tar.gz\"; inherit sha256;"
508+ , " } else (import <nixpkgs> {}).fetchFromGitHub {"
509+ , " inherit owner repo rev sha256 fetchSubmodules private;"
510+ , " };"
511+ , "in import (fetch (builtins.fromJSON (builtins.readFile ./github.json)))"
512+ ]
513+
458514plainGitStandaloneLoaders :: NonEmpty Text
459515plainGitStandaloneLoaders =
460− plainGitStandaloneLoaderV1 :|
461− [ plainGitStandaloneLoaderV2
516+ plainGitStandaloneLoaderV4 :|
517+ [ plainGitStandaloneLoaderV1
518+ , plainGitStandaloneLoaderV2
519+ , plainGitStandaloneLoaderV3
462520 ]
463521
464522plainGitStandaloneLoaderV1 :: Text
@@ -479,6 +537,41 @@ plainGitStandaloneLoaderV2 = T.unlines
479537 , "in import (fetchGit (builtins.fromJSON (builtins.readFile ./git.json)))"
480538 ]
481539
540+-- This loader has a bug because @builtins.fetchGit@ is not given a @ref@
541+-- and will fail to find commits without this because it does shallow clones.
542+plainGitStandaloneLoaderV3 :: Text
543+plainGitStandaloneLoaderV3 = T.unlines
544+ [ "# DO NOT HAND-EDIT THIS FILE"
545+ , "let fetch = {url, rev, ref ? null, sha256 ? null, fetchSubmodules ? false, private ? false, ...}:"
546+ , " let realUrl = let firstChar = builtins.substring 0 1 url; in"
547+ , " if firstChar == \"/\" then /. + url"
548+ , " else if firstChar == \".\" then ./. + url"
549+ , " else url;"
550+ , " in if !fetchSubmodules && private then builtins.fetchGit {"
551+ , " url = realUrl; inherit rev;"
552+ , " } else (import <nixpkgs> {}).fetchgit {"
553+ , " url = realUrl; inherit rev sha256;"
554+ , " };"
555+ , "in import (fetch (builtins.fromJSON (builtins.readFile ./git.json)))"
556+ ]
557+
558+plainGitStandaloneLoaderV4 :: Text
559+plainGitStandaloneLoaderV4 = T.unlines
560+ [ "# DO NOT HAND-EDIT THIS FILE"
561+ , "let fetch = {url, rev, branch ? null, sha256 ? null, fetchSubmodules ? false, private ? false, ...}:"
562+ , " let realUrl = let firstChar = builtins.substring 0 1 url; in"
563+ , " if firstChar == \"/\" then /. + url"
564+ , " else if firstChar == \".\" then ./. + url"
565+ , " else url;"
566+ , " in if !fetchSubmodules && private then builtins.fetchGit {"
567+ , " url = realUrl; inherit rev;"
568+ , " ${if branch == null then null else \"ref\"} = branch;"
569+ , " } else (import <nixpkgs> {}).fetchgit {"
570+ , " url = realUrl; inherit rev sha256;"
571+ , " };"
572+ , "in import (fetch (builtins.fromJSON (builtins.readFile ./git.json)))"
573+ ]
574+
482575thunkFileNames :: [FilePath]
483576thunkFileNames = ["default.nix", "github.json", "git.json"]
484577
@@ -505,7 +598,7 @@ nixBuildThunkAttrWithCache thunkDir attr = do
505598 let cacheErrHandler e
506599 | isDoesNotExistError e = return Nothing -- expected from a cache miss
507600 | otherwise = putLog Error (T.pack $ displayException e) >> return Nothing
508− cacheDir = thunkDir </> ".attr-cache"
601+ cacheDir = thunkDir </> attrCacheFileName
509602 cachePath = cacheDir </> attr <.> "out"
510603 latestChange <- liftIO $ do
511604 createDirectoryIfMissing False cacheDir
@@ -520,7 +613,7 @@ nixBuildThunkAttrWithCache thunkDir attr = do
520613 Just c -> return c
521614 Nothing -> do
522615 putLog Warning $ T.pack $ mconcat [thunkDir, ": ", attr, " not cached, building ..."]
523− _ <- nixCmd $ NixCmd_Build$ def
616+ _ <- nixCmd $ NixCmd_Build $ def
524617 Lens.& nixBuildConfig_outLink Lens..~ OutLink_IndirectRoot cachePath
525618 Lens.& nixCmdConfig_target Lens..~ Target
526619 { _target_path = Just thunkDir
@@ -568,13 +661,13 @@ updateThunk p f = withSystemTempDirectory "obelisk-thunkptr-" $ \tmpDir -> do
568661 Right (ThunkData_Packed _) -> do
569662 let tmpThunk = tmpDir </> "thunk"
570663 callProcessAndLogOutput (Notice, Error) $
571− proc "cp" ["-r", "-T", thunkDir, tmpThunk]
664+ proc cp ["-r", "-T", thunkDir, tmpThunk]
572665 return tmpThunk
573− Right _ -> failWith $ "Thunk is not packed"
666+ Right _ -> failWith "Thunk is not packed"
574667 updateThunkFromTmp p' = do
575− _ <- packThunk' True False p'
668+ _ <- packThunk' True (ThunkPackConfig False (ThunkConfig Nothing)) p'
576669 callProcessAndLogOutput (Notice, Error) $
577− proc "cp" ["-r", "-T", p', p]
670+ proc cp ["-r", "-T", p', p]
578671
579672finalMsg :: Bool -> (a -> Text) -> Maybe (a -> Text)
580673finalMsg noTrail s = if noTrail then Nothing else Just s
@@ -606,7 +699,7 @@ unpackThunk' noTrail thunkDir = checkThunkDirectory "Can't pack/unpack from with
606699 let git = callProcessAndLogOutput (Notice, Notice) . gitProc tmpRepo
607700 git $ [ "clone" ]
608701 ++ ("--recursive" <$ guard (_gitSource_fetchSubmodules s))
609− ++ [ T.unpack $ render $ _gitSource_url s ]
702+ ++ [ T.unpack $ gitUriToText $ _gitSource_url s ]
610703 ++ do branch <- maybeToList $ _gitSource_branch s
611704 [ "--branch", T.unpack $ untagName branch ]
612705 git ["reset", "--hard", Ref.toHexString $ _thunkRev_commit $ _thunkPtr_rev tptr]
@@ -615,31 +708,39 @@ unpackThunk' noTrail thunkDir = checkThunkDirectory "Can't pack/unpack from with
615708
616709 liftIO $ createDirectory obGitDir
617710 callProcessAndLogOutput (Notice, Error) $
618− proc "cp" ["-r", "-T", thunkDir </> ".", obGitDir </> "orig-thunk"]
711+ proc cp ["-r", "-T", thunkDir </> ".", obGitDir </> "orig-thunk"]
619712 callProcessAndLogOutput (Notice, Error) $
620713 proc "rm" ["-r", thunkDir]
621714 callProcessAndLogOutput (Notice, Error) $
622715 proc "mv" ["-T", tmpRepo, thunkDir]
623716
624717--TODO: add a rollback mode to pack to the original thunk
625−packThunk :: MonadObelisk m => Bool -> FilePath -> m ThunkPtr
718+packThunk :: MonadObelisk m => ThunkPackConfig -> FilePath -> m ThunkPtr
626719packThunk = packThunk' False
627720
628−packThunk' :: MonadObelisk m => Bool -> Bool -> FilePath -> m ThunkPtr
629−packThunk' noTrail force thunkDir = checkThunkDirectory "Can't pack/unpack from within the thunk directory" thunkDir >> readThunk thunkDir >>= \case
721+packThunk' :: MonadObelisk m => Bool -> ThunkPackConfig -> FilePath -> m ThunkPtr
722+packThunk' noTrail (ThunkPackConfig force thunkConfig) thunkDir = checkThunkDirectory "Can't pack/unpack from within the thunk directory" thunkDir >> readThunk thunkDir >>= \case
630723 Left err -> failWith $ T.pack $ "thunk pack: " <> show err
631724 Right (ThunkData_Packed _) -> failWith "pack: thunk is already packed"
632725 Right (ThunkData_Checkout _) -> do
633726 withSpinner' ("Packing thunk " <> T.pack thunkDir)
634727 (finalMsg noTrail $ const $ "Packed thunk " <> T.pack thunkDir) $ do
635− thunkPtr <- getThunkPtr (not force) thunkDir
728+ thunkPtr <- modifyThunkPtrByConfig thunkConfig <$> getThunkPtr (not force) thunkDir (_thunkConfig_private thunkConfig)
636729 callProcessAndLogOutput (Debug, Error) $ proc "rm" ["-rf", thunkDir]
637730 liftIO $ createThunk thunkDir thunkPtr
638731 pure thunkPtr
639732
640−getThunkPtr :: forall m. MonadObelisk m => Bool -> FilePath -> m ThunkPtr
641−getThunkPtr checkClean thunkDir = do
642− when checkClean $ ensureCleanGitRepo thunkDir True $
733+modifyThunkPtrByConfig :: ThunkConfig -> ThunkPtr -> ThunkPtr
734+modifyThunkPtrByConfig (ThunkConfig markPrivate') ptr = case markPrivate' of
735+ Nothing -> ptr
736+ Just markPrivate -> ptr { _thunkPtr_source = case _thunkPtr_source ptr of
737+ ThunkSource_Git s -> ThunkSource_Git $ s { _gitSource_private = markPrivate }
738+ ThunkSource_GitHub s -> ThunkSource_GitHub $ s { _gitHubSource_private = markPrivate }
739+ }
740+
741+getThunkPtr :: forall m. MonadObelisk m => Bool -> FilePath -> Maybe Bool -> m ThunkPtr
742+getThunkPtr checkClean thunkDir mPrivate = do
743+ when checkClean $ ensureCleanGitRepo thunkDir True
643744 "thunk pack: thunk checkout contains unsaved modifications"
644745
645746 -- Check whether there are any stashes
@@ -652,7 +753,7 @@ getThunkPtr checkClean thunkDir = do
652753 ] ++ T.lines stashOutput
653754 True -> return ()
654755
655− -- Get current branch ``
756+ -- Get current branch
656757 (mCurrentBranch, mCurrentCommit) <- do
657758 b <- listToMaybe
658759 <$> T.lines
@@ -661,7 +762,7 @@ getThunkPtr checkClean thunkDir = do
661762 <$> T.lines
662763 <$> readGitProcess thunkDir ["rev-parse", "HEAD"]
663764 case b of
664− (Just "HEAD") -> failWith $ T.unlines $
765+ (Just "HEAD") -> failWith $ T.unlines
665766 [ "thunk pack: You are in 'detached HEAD' state."
666767 , "If you want to pack at the current ref \
667768 \then please create a new branch with 'git checkout -b <new-branch-name>' and push this upstream."
@@ -733,7 +834,7 @@ getThunkPtr checkClean thunkDir = do
733834 [ "thunk pack: Certain branches in the thunk have commits not yet pushed upstream:"
734835 , ""
735836 ] ++
736− (flip map (Map.toList nonGood) $ \(branch, (upstream, (ahead, behind))) -> mconcat
837+ flip map (Map.toList nonGood) (\(branch, (upstream, (ahead, behind))) -> mconcat
737838 [" ", branch, " ahead: ", T.pack (show ahead), " behind: ", T.pack (show behind), " remote branch ", upstream]) ++
738839 [ ""
739840 , "Please push these upstream and try again. (Or just fetch, if they are somehow \
@@ -741,7 +842,7 @@ getThunkPtr checkClean thunkDir = do
741842 ]
742843
743844 -- We assume it's safe to pack the thunk at this point
744− putLog Informational $ "All changes safe in git remotes. OK to pack thunk."
845+ putLog Informational "All changes safe in git remotes. OK to pack thunk."
745846
746847 let remote = maybe "origin" snd $ flip Map.lookup headUpstream =<< mCurrentBranch
747848
@@ -754,7 +855,7 @@ getThunkPtr checkClean thunkDir = do
754855 remoteUri <- case parseGitUri remoteUri' of
755856 Nothing -> failWith $ "Could not identify git remote: " <> remoteUri'
756857 Just uri -> pure uri
757− uriThunkPtr remoteUri mCurrentBranch mCurrentCommit
858+ uriThunkPtr remoteUri mPrivate mCurrentBranch mCurrentCommit
758859
759860-- | Get the latest revision available from the given source
760861getLatestRev :: MonadObelisk m => ThunkSource -> m ThunkRev
@@ -773,18 +874,18 @@ getLatestRev os = do
773874-- performance. If that doesn't work (e.g. authentication issue), we fall back
774875-- on just doing things the normal way for git repos in general, and save it as
775876-- a regular git thunk.
776−uriThunkPtr :: MonadObelisk m => URI -> Maybe Text -> Maybe Text -> m ThunkPtr
777−uriThunkPtr uri mbranch mcommit = do
877+uriThunkPtr :: MonadObelisk m => GitUri -> Maybe Bool -> Maybe Text -> Maybe Text -> m ThunkPtr
878+uriThunkPtr uri mPrivate mbranch mcommit = do
778879 commit <- case mcommit of
779880 Nothing -> gitGetCommitBranch uri mbranch >>= return . snd
780881 (Just c) -> return c
781− (src, rev) <- case uriToThunkSource uri mbranch of
882+ (src, rev) <- uriToThunkSource uri mPrivate mbranch >>= \case
782883 ThunkSource_GitHub s -> do
783884 rev <- runExceptT $ githubThunkRev s commit
784885 case rev of
785886 Right r -> pure (ThunkSource_GitHub s, r)
786887 Left e -> do
787− putLog Warning $ "\
888+ putLog Warning "\
788889\Failed to fetch archive from GitHub. This is probably a private repo. \
789890\Falling back on normal fetchgit. Original failure:"
790891 errorToWarning e
@@ -801,34 +902,66 @@ uriThunkPtr uri mbranch mcommit = do
801902-- If the thunk is a GitHub thunk and fails, we do *not* fall back like with
802903-- `uriThunkPtr`. Unlike a plain URL, a thunk src explicitly states which method
803904-- should be employed, and so we respect that.
804−uriToThunkSource :: URI -> Maybe Text -> ThunkSource
805−uriToThunkSource u
806− | Right uriAuth <- uriAuthority u
807− , Just scheme <- unRText <$> uriScheme u
905+uriToThunkSource :: MonadObelisk m => GitUri -> Maybe Bool -> Maybe Text -> m ThunkSource
906+uriToThunkSource (GitUri u) mPrivate
907+ | Right uriAuth <- URI.uriAuthority u
908+ , Just scheme <- URI.unRText <$> URI.uriScheme u
808909 , case scheme of
809− "ssh" -> uriAuth == Authority
810− { authUserInfo = Just $ UserInfo (fromRight' $ mkUsername "git") Nothing
811− , authHost = fromRight' $ mkHost "github.com"
812− , authPort = Nothing
910+ "ssh" -> uriAuth == URI.Authority
911+ { URI.authUserInfo = Just $ URI.UserInfo (fromRight' $ URI.mkUsername "git") Nothing
912+ , URI.authHost = fromRight' $ URI.mkHost "github.com"
913+ , URI.authPort = Nothing
813914 }
814915 s -> s `L.elem` [ "git", "https", "http" ] -- "http:" just redirects to "https:"
815− && unRText (authHost uriAuth) == "github.com"
816− , Just (_, owner :| [repoish]) <- uriPath u
817− = \mbranch -> ThunkSource_GitHub $ GitHubSource
818− { _gitHubSource_owner = N $ unRText owner
819− , _gitHubSource_repo = N $ let
820− repoish' = unRText repoish
821− in case T.stripSuffix ".git" repoish' of
822− Just repo -> repo
823− Nothing -> repoish'
824− , _gitHubSource_branch = N <$> mbranch
825− }
916+ && URI.unRText (URI.authHost uriAuth) == "github.com"
917+ , Just (_, owner :| [repoish]) <- URI.uriPath u
918+ = \mbranch -> do
919+ isPrivate <- getIsPrivate
920+ pure $ ThunkSource_GitHub $ GitHubSource
921+ { _gitHubSource_owner = N $ URI.unRText owner
922+ , _gitHubSource_repo = N $ let
923+ repoish' = URI.unRText repoish
924+ in fromMaybe repoish' $ T.stripSuffix ".git" repoish'
925+ , _gitHubSource_branch = N <$> mbranch
926+ , _gitHubSource_private = isPrivate
927+ }
826928
827− | otherwise = \mbranch -> ThunkSource_Git $ GitSource
828− { _gitSource_url = u
829− , _gitSource_branch = N <$> mbranch
830− , _gitSource_fetchSubmodules = False -- TODO: How do we determine if this should be true?
831− }
929+ | otherwise = \mbranch -> do
930+ isPrivate <- getIsPrivate
931+ pure $ ThunkSource_Git $ GitSource
932+ { _gitSource_url = GitUri u
933+ , _gitSource_branch = N <$> mbranch
934+ , _gitSource_fetchSubmodules = False -- TODO: How do we determine if this should be true?
935+ , _gitSource_private = isPrivate
936+ }
937+ where
938+ getIsPrivate = maybe (guessGitRepoIsPrivate $ GitUri u) pure mPrivate
939+
940+guessGitRepoIsPrivate :: MonadObelisk m => GitUri -> m Bool
941+guessGitRepoIsPrivate uri = flip fix urisToTry $ \loop -> \case
942+ [] -> pure True
943+ uriAttempt:xs -> do
944+ result <- readCreateProcessWithExitCode $
945+ isolateGitProc $
946+ gitProcNoRepo
947+ [ "ls-remote"
948+ , "--quiet"
949+ , "--exit-code"
950+ , "--symref"
951+ , T.unpack $ gitUriToText uriAttempt
952+ ]
953+ case result of
954+ (ExitSuccess, _, _) -> pure False -- Must be a public repo
955+ _ -> loop xs
956+ where
957+ urisToTry = nubOrd $
958+ -- Include the original URI if it isn't using SSH because SSH will certainly fail.
959+ [uri | fmap URI.unRText (URI.uriScheme (unGitUri uri)) /= Just "ssh"] <>
960+ [changeScheme "https" uri, changeScheme "http" uri]
961+ changeScheme scheme (GitUri u) = GitUri $ u
962+ { URI.uriScheme = URI.mkScheme scheme
963+ , URI.uriAuthority = (\x -> x { URI.authUserInfo = Nothing }) <$> URI.uriAuthority u
964+ }
832965
833966-- Funny signature indicates no effects depend on the optional branch name.
834967githubThunkRev
@@ -840,19 +973,19 @@ githubThunkRev
840973githubThunkRev s commit = do
841974 owner <- forcePP $ _gitHubSource_owner s
842975 repo <- forcePP $ _gitHubSource_repo s
843− revTarball <- mkPathPiece $ commit <> ".tar.gz"
844− let archiveUri = URI
845− { uriScheme = Just $ fromRight' $ mkScheme "https"
846− , uriAuthority = Right $ Authority
847− { authUserInfo = Nothing
848− , authHost = fromRight' $ mkHost "github.com"
849− , authPort = Nothing
976+ revTarball <- URI.mkPathPiece $ commit <> ".tar.gz"
977+ let archiveUri = GitUri $ URI.URI
978+ { URI.uriScheme = Just $ fromRight' $ URI.mkScheme "https"
979+ , URI.uriAuthority = Right $ URI.Authority
980+ { URI.authUserInfo = Nothing
981+ , URI.authHost = fromRight' $ URI.mkHost "github.com"
982+ , URI.authPort = Nothing
850983 }
851− , uriPath = Just ( False
852− , owner :| [ repo, fromRight' $ mkPathPiece "archive", revTarball ]
984+ , URI.uriPath = Just ( False
985+ , owner :| [ repo, fromRight' $ URI.mkPathPiece "archive", revTarball ]
853986 )
854− , uriQuery = []
855− , uriFragment = Nothing
987+ , URI.uriQuery = []
988+ , URI.uriFragment = Nothing
856989 }
857990 hash <- getNixSha256ForUriUnpacked archiveUri
858991 putLog Debug $ "Nix sha256 is " <> hash
@@ -861,8 +994,8 @@ githubThunkRev s commit = do
861994 , _thunkRev_nixSha256 = hash
862995 }
863996 where
864− forcePP :: Name entity -> m (RText 'PathPiece)
865− forcePP = mkPathPiece . untagName
997+ forcePP :: Name entity -> m (URI.RText 'URI.PathPiece)
998+ forcePP = URI.mkPathPiece . untagName
866999
8671000gitThunkRev
8681001 :: MonadObelisk m
@@ -871,11 +1004,11 @@ gitThunkRev
8711004 -> m ThunkRev
8721005gitThunkRev s commit = do
8731006 let u = _gitSource_url s
874− protocols = ["https", "ssh", "git"]
875− Just scheme <- pure $ unRText <$> uriScheme u
1007+ protocols = ["file", "https", "ssh", "git"]
1008+ scheme = maybe "file" URI.unRText $ URI.uriScheme $ (\(GitUri x) -> x) u
8761009 unless (T.toLower scheme `elem` protocols) $
8771010 failWith $ "obelisk currently only supports "
878− <> T.intercalate ", " protocols <> " protocols for non-GitHub remotes"
1011+ <> T.intercalate ", " protocols <> " protocols for plain Git remotes"
8791012 hash <- nixPrefetchGit u commit $ _gitSource_fetchSubmodules s
8801013 putLog Informational $ "Nix sha256 is " <> hash
8811014 pure $ ThunkRev
@@ -888,11 +1021,12 @@ gitThunkRev s commit = do
8881021--
8891022-- If the branch name is passed in, it is returned exactly as-is. If it is not
8901023-- passed it, the default branch of the repo is used instead.
1024+
8911025gitGetCommitBranch
892− :: MonadObelisk m => URI -> Maybe Text -> m (Text, CommitId)
1026+ :: MonadObelisk m => GitUri -> Maybe Text -> m (Text, CommitId)
8931027gitGetCommitBranch uri mbranch = withExitFailMessage ("Failure for git remote " <> uriMsg) $ do
8941028 (_, bothMaps) <- gitLsRemote
895− (T.unpack $ render uri)
1029+ (T.unpack $ gitUriToText uri)
8961030 (GitRef_Branch <$> mbranch)
8971031 Nothing
8981032 branch <- case mbranch of
@@ -908,18 +1042,21 @@ gitGetCommitBranch uri mbranch = withExitFailMessage ("Failure for git remote "
9081042 pure (branch, commit)
9091043 where
9101044 rethrowE = either failWith pure
911− uriMsg = render uri
1045+ uriMsg = gitUriToText uri
1046+
1047+parseGitUri :: Text -> Maybe GitUri
1048+parseGitUri x = GitUri <$> (parseFileURI x <|> parseAbsoluteURI x <|> parseSshShorthand x)
9121049
913−parseGitUri :: Text -> Maybe URI
914−parseGitUri x = parseAbsoluteURI x <|> parseSshShorthand x
1050+parseFileURI :: Text -> Maybe URI.URI
1051+parseFileURI uri = if "/" `T.isPrefixOf` uri then parseAbsoluteURI ("file://" <> uri) else Nothing
9151052
916−parseAbsoluteURI :: Text -> Maybe URI
1053+parseAbsoluteURI :: Text -> Maybe URI.URI
9171054parseAbsoluteURI uri = do
918− parsedUri <- mkURI uri
919− guard $ isPathAbsolute parsedUri
920− pure $ parsedUri
1055+ parsedUri <- URI.mkURI uri
1056+ guard $ URI.isPathAbsolute parsedUri
1057+ pure parsedUri
9211058
922−parseSshShorthand :: Text -> Maybe URI
1059+parseSshShorthand :: Text -> Maybe URI.URI
9231060parseSshShorthand uri = do
9241061 -- This is what git does to check that the remote
9251062 -- is not a local file path when parsing shorthand.
@@ -932,4 +1069,4 @@ parseSshShorthand uri = do
9321069 -- This check is used to disambiguate a filepath containing a colon from shorthand
9331070 guard $ isNothing (T.findIndex (=='/') authAndHostname)
9341071 && not (T.null colonAndPath)
935− mkURI properUri
1072+ URI.mkURI properUri