@@ -8,26 +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− , getThunkPtr'
30− , parseGitUri
35+ , updateThunkToLatest
3136 , uriThunkPtr
3237 ) where
3338
@@ -43,6 +48,7 @@ import qualified Data.Aeson as Aeson
4348import Data.Aeson.Encode.Pretty
4449import qualified Data.Aeson.Types as Aeson
4550import qualified Data.ByteString.Lazy as LBS
51+import Data.Containers.ListUtils (nubOrd)
4652import Data.Default
4753import Data.Either.Combinators (fromRight', rightToMaybe)
4854import Data.Git.Ref (Ref)
@@ -65,12 +71,12 @@ import GitHub
6571import GitHub.Data.Name
6672import Obelisk.Command.Nix
6773import System.Directory
74+import System.Exit
6875import System.FilePath
6976import System.IO.Error
7077import System.IO.Temp
7178import System.Posix (getSymbolicLinkStatus, modificationTime)
72−import System.Process (proc)
73−import Text.URI
79+import qualified Text.URI as URI
7480
7581import Obelisk.App (MonadObelisk)
7682import Obelisk.CliApp
@@ -95,7 +101,7 @@ type NixSha256 = Text --TODO: Use a smart constructor and make this actually ver
95101
96102-- | A specific revision of data; it may be available from multiple sources
97103data ThunkRev = ThunkRev
98− { _thunkRev_commit :: Ref
104+ { _thunkRev_commit :: Ref Ref.SHA1
99105 , _thunkRev_nixSha256 :: NixSha256
100106 }
101107 deriving (Show, Eq, Ord)
@@ -112,37 +118,63 @@ data GitHubSource = GitHubSource
112118 { _gitHubSource_owner :: Name Owner
113119 , _gitHubSource_repo :: Name Repo
114120 , _gitHubSource_branch :: Maybe (Name Branch)
121+ , _gitHubSource_private :: Bool
115122 }
116123 deriving (Show, Eq, Ord)
117124
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+
118134data GitSource = GitSource
119− { _gitSource_url :: URI
135+ { _gitSource_url :: GitUri
120136 , _gitSource_branch :: Maybe (Name Branch)
121137 , _gitSource_fetchSubmodules :: Bool
138+ , _gitSource_private :: Bool
122139 }
123140 deriving (Show, Eq, Ord)
124141
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+
125156-- | Convert a GitHub source to a regular Git source. Assumes no submodules.
126157forgetGithub :: Bool -> GitHubSource -> GitSource
127158forgetGithub 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
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
132163 <$ guard useSsh
133− , authHost = fromRight' $ mkHost "github.com"
134− , authPort = Nothing
164+ , URI.authHost = fromRight' $ URI.mkHost "github.com"
165+ , URI.authPort = Nothing
135166 }
136− , uriPath = Just ( False
137− , fromRight' . mkPathPiece <$>
167+ , URI.uriPath = Just ( False
168+ , fromRight' . URI.mkPathPiece <$>
138169 untagName (_gitHubSource_owner s)
139170 :| [ untagName (_gitHubSource_repo s) <> ".git" ]
140171 )
141− , uriQuery = []
142− , uriFragment = Nothing
172+ , URI.uriQuery = []
173+ , URI.uriFragment = Nothing
143174 }
144175 , _gitSource_branch = _gitHubSource_branch s
145176 , _gitSource_fetchSubmodules = False
177+ , _gitSource_private = _gitHubSource_private s
146178 }
147179
148180getThunkGitBranch :: ThunkPtr -> Maybe Text
@@ -150,26 +182,26 @@ getThunkGitBranch (ThunkPtr _ src) = fmap untagName $ case src of
150182 ThunkSource_GitHub s -> _gitHubSource_branch s
151183 ThunkSource_Git s -> _gitSource_branch s
152184
153−commitNameToRef :: Name Commit -> Ref
185+commitNameToRef :: Name Commit -> Ref Ref.SHA1
154186commitNameToRef (N c) = Ref.fromHex $ encodeUtf8 c
155187
156188-- TODO: Use spinner here.
157189getNixSha256ForUriUnpacked
158190 :: MonadObelisk m
159− => URI
191+ => GitUri
160192 -> m NixSha256
161193getNixSha256ForUriUnpacked uri =
162− 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
163195 [hash] <- fmap T.lines $ readProcessAndLogOutput (Debug, Debug) $
164− proc "nix-prefetch-url" ["--unpack" , "--type" , "sha256" , T.unpack $ render uri]
196+ proc "nix-prefetch-url" ["--unpack", "--type", "sha256", T.unpack $ gitUriToText uri]
165197 pure hash
166198
167−nixPrefetchGit :: MonadObelisk m => URI -> Text -> Bool -> m NixSha256
199+nixPrefetchGit :: MonadObelisk m => GitUri -> Text -> Bool -> m NixSha256
168200nixPrefetchGit uri rev fetchSubmodules =
169− 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
170202 out <- readProcessAndLogStderr Debug $
171203 proc "nix-prefetch-git" $ filter (/="")
172− [ "--url", T.unpack $ render uri
204+ [ "--url", T.unpack $ gitUriToText uri
173205 , "--rev", T.unpack rev
174206 , if fetchSubmodules then "--fetch-submodules" else ""
175207 , "--quiet"
@@ -200,6 +232,9 @@ readThunk thunkDir = do
200232 False -> return $ return Nothing
201233 False -> liftIO $ fmap ThunkData_Packed <$> readPackedThunk thunkDir
202234
235+attrCacheFileName :: FilePath
236+attrCacheFileName = ".attr-cache"
237+
203238data ThunkType = ThunkType
204239 { _thunkType_loader :: FilePath
205240 , _thunkType_json :: FilePath
@@ -212,7 +247,7 @@ gitHubThunkType :: ThunkType
212247gitHubThunkType = ThunkType
213248 { _thunkType_loader = "default.nix"
214249 , _thunkType_json = "github.json"
215− , _thunkType_optional = Set.fromList [".attr-cache"]
250+ , _thunkType_optional = Set.fromList [attrCacheFileName]
216251 , _thunkType_loaderVersions = gitHubStandaloneLoaders
217252 , _thunkType_parser = parseThunkPtr $ \v ->
218253 ThunkSource_GitHub <$> parseGitHubSource v <|> ThunkSource_Git <$> parseGitSource v
@@ -222,7 +257,7 @@ gitThunkType :: ThunkType
222257gitThunkType = ThunkType
223258 { _thunkType_loader = "default.nix"
224259 , _thunkType_json = "git.json"
225− , _thunkType_optional = Set.fromList [".attr-cache"]
260+ , _thunkType_optional = Set.fromList [attrCacheFileName]
226261 , _thunkType_loaderVersions = plainGitStandaloneLoaders
227262 , _thunkType_parser = parseThunkPtr $ fmap ThunkSource_Git . parseGitSource
228263 }
@@ -287,10 +322,12 @@ parseGitHubSource v = do
287322 owner <- v Aeson..: "owner"
288323 repo <- v Aeson..: "repo"
289324 branch <- v Aeson..:! "branch"
325+ private <- v Aeson..:? "private"
290326 pure $ GitHubSource
291327 { _gitHubSource_owner = owner
292328 , _gitHubSource_repo = repo
293329 , _gitHubSource_branch = branch
330+ , _gitHubSource_private = fromMaybe False private
294331 }
295332
296333parseGitSource :: Aeson.Object -> Aeson.Parser GitSource
@@ -298,10 +335,12 @@ parseGitSource v = do
298335 Just url <- parseGitUri <$> v Aeson..: "url"
299336 branch <- v Aeson..:! "branch"
300337 fetchSubmodules <- v Aeson..:! "fetchSubmodules"
338+ private <- v Aeson..:? "private"
301339 pure $ GitSource
302340 { _gitSource_url = url
303341 , _gitSource_branch = branch
304342 , _gitSource_fetchSubmodules = fromMaybe False fetchSubmodules
343+ , _gitSource_private = fromMaybe False private
305344 }
306345
307346overwriteThunk :: MonadObelisk m => FilePath -> ThunkPtr -> m ()
@@ -328,13 +367,15 @@ encodeThunkPtrData (ThunkPtr rev src) = case src of
328367 , ("branch" .=) <$> _gitHubSource_branch s
329368 , Just $ "rev" .= Ref.toHexString (_thunkRev_commit rev)
330369 , Just $ "sha256" .= _thunkRev_nixSha256 rev
370+ , Just $ "private" .= _gitHubSource_private s
331371 ]
332372 ThunkSource_Git s -> encodePretty' plainGitCfg $ Aeson.object $ catMaybes
333− [ Just $ "url" .= render (_gitSource_url s)
373+ [ Just $ "url" .= gitUriToText (_gitSource_url s)
334374 , Just $ "rev" .= Ref.toHexString (_thunkRev_commit rev)
335375 , ("branch" .=) <$> _gitSource_branch s
336376 , Just $ "sha256" .= _thunkRev_nixSha256 rev
337377 , Just $ "fetchSubmodules" .= _gitSource_fetchSubmodules s
378+ , Just $ "private" .= _gitSource_private s
338379 ]
339380 where
340381 githubCfg = defConfig
@@ -355,6 +396,7 @@ encodeThunkPtrData (ThunkPtr rev src) = case src of
355396 [ "url"
356397 , "rev"
357398 , "sha256"
399+ , "private"
358400 , "fetchSubmodules"
359401 ] <> compare
360402 , confTrailingNewline = True
@@ -362,7 +404,7 @@ encodeThunkPtrData (ThunkPtr rev src) = case src of
362404
363405createThunk :: MonadIO m => FilePath -> ThunkPtr -> m ()
364406createThunk target thunk = liftIO $ do
365− createDirectoryIfMissing True (target </> ".attr-cache")
407+ createDirectoryIfMissing True (target </> attrCacheFileName)
366408 T.writeFile (target </> "default.nix") (thunkPtrLoader thunk)
367409 let
368410 jsonFileName = case _thunkPtr_source thunk of
@@ -378,8 +420,8 @@ createThunkWithLatest target s = do
378420 , _thunkPtr_rev = rev
379421 }
380422
381−updateThunkToLatest :: MonadObelisk m => FilePath -> Maybe String -> m ()
382−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
383425 checkThunkDirectory "ob thunk update directory cannot be '.'" target
384426 -- check to see if thunk should be updated to a specific branch or just update it's current branch
385427 case mBranch of
@@ -391,7 +433,7 @@ updateThunkToLatest target mBranch = withSpinner' ("Updating thunk " <> T.pack t
391433 ThunkData_Checkout _ -> failWith "cannot update an unpacked thunk"
392434 let src = _thunkPtr_source ptr
393435 rev <- getLatestRev src
394− overwriteThunk overwrite $ ThunkPtr
436+ overwriteThunk overwrite $ modifyThunkPtrByConfig thunkConfig $ ThunkPtr
395437 { _thunkPtr_source = src
396438 , _thunkPtr_rev = rev
397439 }
@@ -399,24 +441,25 @@ updateThunkToLatest target mBranch = withSpinner' ("Updating thunk " <> T.pack t
399441 Left err -> failWith $ T.pack $ "thunk update: " <> show err
400442 Right c -> case c of
401443 ThunkData_Packed t -> case _thunkPtr_source t of
402− ThunkSource_Git tsg -> setThunk target tsg branch
444+ ThunkSource_Git tsg -> setThunk thunkConfig target tsg branch
403445 ThunkSource_GitHub tsgh -> do
404446 let tsg = forgetGithub False tsgh
405− setThunk target tsg branch
406− 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."
407449
408−setThunk :: MonadObelisk m => FilePath -> GitSource -> String -> m ()
409−setThunk target gs branch = do
410− 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
411453 overwriteThunk target newThunkPtr
412− updateThunkToLatest target Nothing
454+ updateThunkToLatest (ThunkUpdateConfig Nothing thunkConfig) target
413455
414456-- | All recognized github standalone loaders, ordered from newest to oldest.
415457-- This tool will only ever produce the newest one when it writes a thunk.
416458gitHubStandaloneLoaders :: NonEmpty Text
417459gitHubStandaloneLoaders =
418− gitHubStandaloneLoaderV2 :|
460+ gitHubStandaloneLoaderV4 :|
419461 [ gitHubStandaloneLoaderV3
462+ , gitHubStandaloneLoaderV2
420463 , gitHubStandaloneLoaderV1
421464 ]
422465
@@ -456,10 +499,24 @@ gitHubStandaloneLoaderV3 = T.unlines
456499 , "in import (fetch (builtins.fromJSON (builtins.readFile ./github.json)))"
457500 ]
458501
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+
459514plainGitStandaloneLoaders :: NonEmpty Text
460515plainGitStandaloneLoaders =
461− plainGitStandaloneLoaderV1 :|
462− [ plainGitStandaloneLoaderV2
516+ plainGitStandaloneLoaderV4 :|
517+ [ plainGitStandaloneLoaderV1
518+ , plainGitStandaloneLoaderV2
519+ , plainGitStandaloneLoaderV3
463520 ]
464521
465522plainGitStandaloneLoaderV1 :: Text
@@ -480,6 +537,41 @@ plainGitStandaloneLoaderV2 = T.unlines
480537 , "in import (fetchGit (builtins.fromJSON (builtins.readFile ./git.json)))"
481538 ]
482539
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+
483575thunkFileNames :: [FilePath]
484576thunkFileNames = ["default.nix", "github.json", "git.json"]
485577
@@ -506,7 +598,7 @@ nixBuildThunkAttrWithCache thunkDir attr = do
506598 let cacheErrHandler e
507599 | isDoesNotExistError e = return Nothing -- expected from a cache miss
508600 | otherwise = putLog Error (T.pack $ displayException e) >> return Nothing
509− cacheDir = thunkDir </> ".attr-cache"
601+ cacheDir = thunkDir </> attrCacheFileName
510602 cachePath = cacheDir </> attr <.> "out"
511603 latestChange <- liftIO $ do
512604 createDirectoryIfMissing False cacheDir
@@ -521,7 +613,7 @@ nixBuildThunkAttrWithCache thunkDir attr = do
521613 Just c -> return c
522614 Nothing -> do
523615 putLog Warning $ T.pack $ mconcat [thunkDir, ": ", attr, " not cached, building ..."]
524− _ <- nixCmd $ NixCmd_Build$ def
616+ _ <- nixCmd $ NixCmd_Build $ def
525617 Lens.& nixBuildConfig_outLink Lens..~ OutLink_IndirectRoot cachePath
526618 Lens.& nixCmdConfig_target Lens..~ Target
527619 { _target_path = Just thunkDir
@@ -569,13 +661,13 @@ updateThunk p f = withSystemTempDirectory "obelisk-thunkptr-" $ \tmpDir -> do
569661 Right (ThunkData_Packed _) -> do
570662 let tmpThunk = tmpDir </> "thunk"
571663 callProcessAndLogOutput (Notice, Error) $
572− proc "cp" ["-r", "-T", thunkDir, tmpThunk]
664+ proc cp ["-r", "-T", thunkDir, tmpThunk]
573665 return tmpThunk
574− Right _ -> failWith $ "Thunk is not packed"
666+ Right _ -> failWith "Thunk is not packed"
575667 updateThunkFromTmp p' = do
576− _ <- packThunk' True p'
668+ _ <- packThunk' True (ThunkPackConfig False (ThunkConfig Nothing)) p'
577669 callProcessAndLogOutput (Notice, Error) $
578− proc "cp" ["-r", "-T", p', p]
670+ proc cp ["-r", "-T", p', p]
579671
580672finalMsg :: Bool -> (a -> Text) -> Maybe (a -> Text)
581673finalMsg noTrail s = if noTrail then Nothing else Just s
@@ -607,7 +699,7 @@ unpackThunk' noTrail thunkDir = checkThunkDirectory "Can't pack/unpack from with
607699 let git = callProcessAndLogOutput (Notice, Notice) . gitProc tmpRepo
608700 git $ [ "clone" ]
609701 ++ ("--recursive" <$ guard (_gitSource_fetchSubmodules s))
610− ++ [ T.unpack $ render $ _gitSource_url s ]
702+ ++ [ T.unpack $ gitUriToText $ _gitSource_url s ]
611703 ++ do branch <- maybeToList $ _gitSource_branch s
612704 [ "--branch", T.unpack $ untagName branch ]
613705 git ["reset", "--hard", Ref.toHexString $ _thunkRev_commit $ _thunkPtr_rev tptr]
@@ -616,35 +708,39 @@ unpackThunk' noTrail thunkDir = checkThunkDirectory "Can't pack/unpack from with
616708
617709 liftIO $ createDirectory obGitDir
618710 callProcessAndLogOutput (Notice, Error) $
619− proc "cp" ["-r", "-T", thunkDir </> ".", obGitDir </> "orig-thunk"]
711+ proc cp ["-r", "-T", thunkDir </> ".", obGitDir </> "orig-thunk"]
620712 callProcessAndLogOutput (Notice, Error) $
621713 proc "rm" ["-r", thunkDir]
622714 callProcessAndLogOutput (Notice, Error) $
623715 proc "mv" ["-T", tmpRepo, thunkDir]
624716
625−--TODO: add force mode to pack even if changes are present
626717--TODO: add a rollback mode to pack to the original thunk
627−packThunk :: MonadObelisk m => FilePath -> m ThunkPtr
718+packThunk :: MonadObelisk m => ThunkPackConfig -> FilePath -> m ThunkPtr
628719packThunk = packThunk' False
629720
630−packThunk' :: MonadObelisk m => Bool -> FilePath -> m ThunkPtr
631−packThunk' noTrail 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
632723 Left err -> failWith $ T.pack $ "thunk pack: " <> show err
633724 Right (ThunkData_Packed _) -> failWith "pack: thunk is already packed"
634725 Right (ThunkData_Checkout _) -> do
635726 withSpinner' ("Packing thunk " <> T.pack thunkDir)
636727 (finalMsg noTrail $ const $ "Packed thunk " <> T.pack thunkDir) $ do
637− thunkPtr <- getThunkPtr thunkDir
728+ thunkPtr <- modifyThunkPtrByConfig thunkConfig <$> getThunkPtr (not force) thunkDir (_thunkConfig_private thunkConfig)
638729 callProcessAndLogOutput (Debug, Error) $ proc "rm" ["-rf", thunkDir]
639730 liftIO $ createThunk thunkDir thunkPtr
640731 pure thunkPtr
641732
642−getThunkPtr :: MonadObelisk m => FilePath -> m ThunkPtr
643−getThunkPtr = getThunkPtr' 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+ }
644740
645−getThunkPtr' :: forall m. MonadObelisk m => Bool -> FilePath -> m ThunkPtr
646−getThunkPtr' checkClean thunkDir = do
647− when checkClean $ ensureCleanGitRepo thunkDir True $
741+getThunkPtr :: forall m. MonadObelisk m => Bool -> FilePath -> Maybe Bool -> m ThunkPtr
742+getThunkPtr checkClean thunkDir mPrivate = do
743+ when checkClean $ ensureCleanGitRepo thunkDir True
648744 "thunk pack: thunk checkout contains unsaved modifications"
649745
650746 -- Check whether there are any stashes
@@ -657,7 +753,7 @@ getThunkPtr' checkClean thunkDir = do
657753 ] ++ T.lines stashOutput
658754 True -> return ()
659755
660− -- Get current branch ``
756+ -- Get current branch
661757 (mCurrentBranch, mCurrentCommit) <- do
662758 b <- listToMaybe
663759 <$> T.lines
@@ -666,7 +762,7 @@ getThunkPtr' checkClean thunkDir = do
666762 <$> T.lines
667763 <$> readGitProcess thunkDir ["rev-parse", "HEAD"]
668764 case b of
669− (Just "HEAD") -> failWith $ T.unlines $
765+ (Just "HEAD") -> failWith $ T.unlines
670766 [ "thunk pack: You are in 'detached HEAD' state."
671767 , "If you want to pack at the current ref \
672768 \then please create a new branch with 'git checkout -b <new-branch-name>' and push this upstream."
@@ -738,7 +834,7 @@ getThunkPtr' checkClean thunkDir = do
738834 [ "thunk pack: Certain branches in the thunk have commits not yet pushed upstream:"
739835 , ""
740836 ] ++
741− (flip map (Map.toList nonGood) $ \(branch, (upstream, (ahead, behind))) -> mconcat
837+ flip map (Map.toList nonGood) (\(branch, (upstream, (ahead, behind))) -> mconcat
742838 [" ", branch, " ahead: ", T.pack (show ahead), " behind: ", T.pack (show behind), " remote branch ", upstream]) ++
743839 [ ""
744840 , "Please push these upstream and try again. (Or just fetch, if they are somehow \
@@ -746,7 +842,7 @@ getThunkPtr' checkClean thunkDir = do
746842 ]
747843
748844 -- We assume it's safe to pack the thunk at this point
749− 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."
750846
751847 let remote = maybe "origin" snd $ flip Map.lookup headUpstream =<< mCurrentBranch
752848
@@ -759,7 +855,7 @@ getThunkPtr' checkClean thunkDir = do
759855 remoteUri <- case parseGitUri remoteUri' of
760856 Nothing -> failWith $ "Could not identify git remote: " <> remoteUri'
761857 Just uri -> pure uri
762− uriThunkPtr remoteUri mCurrentBranch mCurrentCommit
858+ uriThunkPtr remoteUri mPrivate mCurrentBranch mCurrentCommit
763859
764860-- | Get the latest revision available from the given source
765861getLatestRev :: MonadObelisk m => ThunkSource -> m ThunkRev
@@ -778,18 +874,18 @@ getLatestRev os = do
778874-- performance. If that doesn't work (e.g. authentication issue), we fall back
779875-- on just doing things the normal way for git repos in general, and save it as
780876-- a regular git thunk.
781−uriThunkPtr :: MonadObelisk m => URI -> Maybe Text -> Maybe Text -> m ThunkPtr
782−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
783879 commit <- case mcommit of
784880 Nothing -> gitGetCommitBranch uri mbranch >>= return . snd
785881 (Just c) -> return c
786− (src, rev) <- case uriToThunkSource uri mbranch of
882+ (src, rev) <- uriToThunkSource uri mPrivate mbranch >>= \case
787883 ThunkSource_GitHub s -> do
788884 rev <- runExceptT $ githubThunkRev s commit
789885 case rev of
790886 Right r -> pure (ThunkSource_GitHub s, r)
791887 Left e -> do
792− putLog Warning $ "\
888+ putLog Warning "\
793889\Failed to fetch archive from GitHub. This is probably a private repo. \
794890\Falling back on normal fetchgit. Original failure:"
795891 errorToWarning e
@@ -806,34 +902,66 @@ uriThunkPtr uri mbranch mcommit = do
806902-- If the thunk is a GitHub thunk and fails, we do *not* fall back like with
807903-- `uriThunkPtr`. Unlike a plain URL, a thunk src explicitly states which method
808904-- should be employed, and so we respect that.
809−uriToThunkSource :: URI -> Maybe Text -> ThunkSource
810−uriToThunkSource u
811− | Right uriAuth <- uriAuthority u
812− , 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
813909 , case scheme of
814− "ssh" -> uriAuth == Authority
815− { authUserInfo = Just $ UserInfo (fromRight' $ mkUsername "git") Nothing
816− , authHost = fromRight' $ mkHost "github.com"
817− , 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
818914 }
819915 s -> s `L.elem` [ "git", "https", "http" ] -- "http:" just redirects to "https:"
820− && unRText (authHost uriAuth) == "github.com"
821− , Just (_, owner :| [repoish]) <- uriPath u
822− = \mbranch -> ThunkSource_GitHub $ GitHubSource
823− { _gitHubSource_owner = N $ unRText owner
824− , _gitHubSource_repo = N $ let
825− repoish' = unRText repoish
826− in case T.stripSuffix ".git" repoish' of
827− Just repo -> repo
828− Nothing -> repoish'
829− , _gitHubSource_branch = N <$> mbranch
830− }
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+ }
831928
832− | otherwise = \mbranch -> ThunkSource_Git $ GitSource
833− { _gitSource_url = u
834− , _gitSource_branch = N <$> mbranch
835− , _gitSource_fetchSubmodules = False -- TODO: How do we determine if this should be true?
836− }
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+ }
837965
838966-- Funny signature indicates no effects depend on the optional branch name.
839967githubThunkRev
@@ -845,19 +973,19 @@ githubThunkRev
845973githubThunkRev s commit = do
846974 owner <- forcePP $ _gitHubSource_owner s
847975 repo <- forcePP $ _gitHubSource_repo s
848− revTarball <- mkPathPiece $ commit <> ".tar.gz"
849− let archiveUri = URI
850− { uriScheme = Just $ fromRight' $ mkScheme "https"
851− , uriAuthority = Right $ Authority
852− { authUserInfo = Nothing
853− , authHost = fromRight' $ mkHost "github.com"
854− , 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
855983 }
856− , uriPath = Just ( False
857− , owner :| [ repo, fromRight' $ mkPathPiece "archive", revTarball ]
984+ , URI.uriPath = Just ( False
985+ , owner :| [ repo, fromRight' $ URI.mkPathPiece "archive", revTarball ]
858986 )
859− , uriQuery = []
860− , uriFragment = Nothing
987+ , URI.uriQuery = []
988+ , URI.uriFragment = Nothing
861989 }
862990 hash <- getNixSha256ForUriUnpacked archiveUri
863991 putLog Debug $ "Nix sha256 is " <> hash
@@ -866,8 +994,8 @@ githubThunkRev s commit = do
866994 , _thunkRev_nixSha256 = hash
867995 }
868996 where
869− forcePP :: Name entity -> m (RText 'PathPiece)
870− forcePP = mkPathPiece . untagName
997+ forcePP :: Name entity -> m (URI.RText 'URI.PathPiece)
998+ forcePP = URI.mkPathPiece . untagName
871999
8721000gitThunkRev
8731001 :: MonadObelisk m
@@ -876,11 +1004,11 @@ gitThunkRev
8761004 -> m ThunkRev
8771005gitThunkRev s commit = do
8781006 let u = _gitSource_url s
879− protocols = ["https", "ssh", "git"]
880− Just scheme <- pure $ unRText <$> uriScheme u
1007+ protocols = ["file", "https", "ssh", "git"]
1008+ scheme = maybe "file" URI.unRText $ URI.uriScheme $ (\(GitUri x) -> x) u
8811009 unless (T.toLower scheme `elem` protocols) $
8821010 failWith $ "obelisk currently only supports "
883− <> T.intercalate ", " protocols <> " protocols for non-GitHub remotes"
1011+ <> T.intercalate ", " protocols <> " protocols for plain Git remotes"
8841012 hash <- nixPrefetchGit u commit $ _gitSource_fetchSubmodules s
8851013 putLog Informational $ "Nix sha256 is " <> hash
8861014 pure $ ThunkRev
@@ -893,11 +1021,12 @@ gitThunkRev s commit = do
8931021--
8941022-- If the branch name is passed in, it is returned exactly as-is. If it is not
8951023-- passed it, the default branch of the repo is used instead.
1024+
8961025gitGetCommitBranch
897− :: MonadObelisk m => URI -> Maybe Text -> m (Text, CommitId)
1026+ :: MonadObelisk m => GitUri -> Maybe Text -> m (Text, CommitId)
8981027gitGetCommitBranch uri mbranch = withExitFailMessage ("Failure for git remote " <> uriMsg) $ do
8991028 (_, bothMaps) <- gitLsRemote
900− (T.unpack $ render uri)
1029+ (T.unpack $ gitUriToText uri)
9011030 (GitRef_Branch <$> mbranch)
9021031 Nothing
9031032 branch <- case mbranch of
@@ -913,18 +1042,21 @@ gitGetCommitBranch uri mbranch = withExitFailMessage ("Failure for git remote "
9131042 pure (branch, commit)
9141043 where
9151044 rethrowE = either failWith pure
916− uriMsg = render uri
1045+ uriMsg = gitUriToText uri
1046+
1047+parseGitUri :: Text -> Maybe GitUri
1048+parseGitUri x = GitUri <$> (parseFileURI x <|> parseAbsoluteURI x <|> parseSshShorthand x)
9171049
918−parseGitUri :: Text -> Maybe URI
919−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
9201052
921−parseAbsoluteURI :: Text -> Maybe URI
1053+parseAbsoluteURI :: Text -> Maybe URI.URI
9221054parseAbsoluteURI uri = do
923− parsedUri <- mkURI uri
924− guard $ isPathAbsolute parsedUri
925− pure $ parsedUri
1055+ parsedUri <- URI.mkURI uri
1056+ guard $ URI.isPathAbsolute parsedUri
1057+ pure parsedUri
9261058
927−parseSshShorthand :: Text -> Maybe URI
1059+parseSshShorthand :: Text -> Maybe URI.URI
9281060parseSshShorthand uri = do
9291061 -- This is what git does to check that the remote
9301062 -- is not a local file path when parsing shorthand.
@@ -937,4 +1069,4 @@ parseSshShorthand uri = do
9371069 -- This check is used to disambiguate a filepath containing a colon from shorthand
9381070 guard $ isNothing (T.findIndex (=='/') authAndHostname)
9391071 && not (T.null colonAndPath)
940− mkURI properUri
1072+ URI.mkURI properUri