@@ -8,26 +8,31 @@
8{-# LANGUAGE ScopedTypeVariables #-}
8{-# LANGUAGE ScopedTypeVariables #-}
9{-# LANGUAGE TypeApplications #-}
9{-# LANGUAGE TypeApplications #-}
10module Obelisk.Command.Thunk
10module Obelisk.Command.Thunk
11− ( ThunkPtr (..)
11+ ( GitHubSource (..)
13+ , ReadThunkError (..)
16+ , ThunkPackConfig (..)
12 , ThunkRev (..)
18 , ThunkRev (..)
13 , ThunkSource (..)
19 , ThunkSource (..)
14− , ThunkData (..)
20+ , ThunkUpdateConfig (..)
15− , ReadThunkError (..)
21+ , attrCacheFileName
19− , updateThunkToLatest
20 , createThunk
22 , createThunk
21 , createThunkWithLatest
23 , createThunkWithLatest
22 , nixBuildAttrWithCache
28 , nixBuildAttrWithCache
23 , nixBuildThunkAttrWithCache
29 , nixBuildThunkAttrWithCache
25 , packThunk
30 , packThunk
26 , readThunk
32 , readThunk
27 , updateThunk
34 , updateThunk
28− , getThunkPtr
35+ , updateThunkToLatest
31 , uriThunkPtr
36 , uriThunkPtr
@@ -43,6 +48,7 @@ import qualified Data.Aeson as Aeson
43import Data.Aeson.Encode.Pretty
48import Data.Aeson.Encode.Pretty
44import qualified Data.Aeson.Types as Aeson
49import qualified Data.Aeson.Types as Aeson
45import qualified Data.ByteString.Lazy as LBS
50import qualified Data.ByteString.Lazy as LBS
51+import Data.Containers.ListUtils (nubOrd)
46import Data.Default
52import Data.Default
47import Data.Either.Combinators (fromRight', rightToMaybe)
53import Data.Either.Combinators (fromRight', rightToMaybe)
48import Data.Git.Ref (Ref)
54import Data.Git.Ref (Ref)
@@ -65,12 +71,12 @@ import GitHub
65import GitHub.Data.Name
71import GitHub.Data.Name
66import Obelisk.Command.Nix
72import Obelisk.Command.Nix
67import System.Directory
73import System.Directory
68import System.FilePath
75import System.FilePath
69import System.IO.Error
76import System.IO.Error
70import System.IO.Temp
77import System.IO.Temp
71import System.Posix (getSymbolicLinkStatus, modificationTime)
78import System.Posix (getSymbolicLinkStatus, modificationTime)
72−import System.Process (proc)
79+import qualified Text.URI as URI
75import Obelisk.App (MonadObelisk)
81import Obelisk.App (MonadObelisk)
76import Obelisk.CliApp
82import Obelisk.CliApp
@@ -95,7 +101,7 @@ type NixSha256 = Text --TODO: Use a smart constructor and make this actually ver
96-- | A specific revision of data; it may be available from multiple sources
102-- | A specific revision of data; it may be available from multiple sources
97data ThunkRev = ThunkRev
103data ThunkRev = ThunkRev
98− { _thunkRev_commit :: Ref
104+ { _thunkRev_commit :: Ref Ref.SHA1
99 , _thunkRev_nixSha256 :: NixSha256
105 , _thunkRev_nixSha256 :: NixSha256
101 deriving (Show, Eq, Ord)
107 deriving (Show, Eq, Ord)
@@ -112,37 +118,63 @@ data GitHubSource = GitHubSource
112 { _gitHubSource_owner :: Name Owner
118 { _gitHubSource_owner :: Name Owner
113 , _gitHubSource_repo :: Name Repo
119 , _gitHubSource_repo :: Name Repo
114 , _gitHubSource_branch :: Maybe (Name Branch)
120 , _gitHubSource_branch :: Maybe (Name Branch)
121+ , _gitHubSource_private :: Bool
116 deriving (Show, Eq, Ord)
123 deriving (Show, Eq, Ord)
125+newtype GitUri = GitUri { unGitUri :: URI.URI } deriving (Eq, Ord, Show)
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
118data GitSource = GitSource
134data GitSource = GitSource
119− { _gitSource_url :: URI
135+ { _gitSource_url :: GitUri
120 , _gitSource_branch :: Maybe (Name Branch)
136 , _gitSource_branch :: Maybe (Name Branch)
121 , _gitSource_fetchSubmodules :: Bool
137 , _gitSource_fetchSubmodules :: Bool
138+ , _gitSource_private :: Bool
123 deriving (Show, Eq, Ord)
140 deriving (Show, Eq, Ord)
142+newtype ThunkConfig = ThunkConfig
143+ { _thunkConfig_private :: Maybe Bool
146+data ThunkUpdateConfig = ThunkUpdateConfig
147+ { _thunkUpdateConfig_branch :: Maybe String
148+ , _thunkUpdateConfig_config :: ThunkConfig
151+data ThunkPackConfig = ThunkPackConfig
152+ { _thunkPackConfig_force :: Bool
153+ , _thunkPackConfig_config :: ThunkConfig
125-- | Convert a GitHub source to a regular Git source. Assumes no submodules.
156-- | Convert a GitHub source to a regular Git source. Assumes no submodules.
126forgetGithub :: Bool -> GitHubSource -> GitSource
157forgetGithub :: Bool -> GitHubSource -> GitSource
127forgetGithub useSsh s = GitSource
158forgetGithub useSsh s = GitSource
128− { _gitSource_url = URI
159+ { _gitSource_url = GitUri $ URI.URI
129− { uriScheme = Just $ fromRight' $ mkScheme $ if useSsh then "ssh" else "https"
160+ { URI.uriScheme = Just $ fromRight' $ URI.mkScheme $ if useSsh then "ssh" else "https"
130− , uriAuthority = Right $ Authority
161+ , URI.uriAuthority = Right $ URI.Authority
131− { authUserInfo = UserInfo (fromRight' $ mkUsername "git") Nothing
162+ { URI.authUserInfo = URI.UserInfo (fromRight' $ URI.mkUsername "git") Nothing
132 <$ guard useSsh
163 <$ guard useSsh
133− , authHost = fromRight' $ mkHost "github.com"
164+ , URI.authHost = fromRight' $ URI.mkHost "github.com"
134− , authPort = Nothing
165+ , URI.authPort = Nothing
136− , uriPath = Just ( False
167+ , URI.uriPath = Just ( False
137− , fromRight' . mkPathPiece <$>
168+ , fromRight' . URI.mkPathPiece <$>
138 untagName (_gitHubSource_owner s)
169 untagName (_gitHubSource_owner s)
139 :| [ untagName (_gitHubSource_repo s) <> ".git" ]
170 :| [ untagName (_gitHubSource_repo s) <> ".git" ]
141− , uriQuery = []
172+ , URI.uriQuery = []
142− , uriFragment = Nothing
173+ , URI.uriFragment = Nothing
144 , _gitSource_branch = _gitHubSource_branch s
175 , _gitSource_branch = _gitHubSource_branch s
145 , _gitSource_fetchSubmodules = False
176 , _gitSource_fetchSubmodules = False
177+ , _gitSource_private = _gitHubSource_private s
148getThunkGitBranch :: ThunkPtr -> Maybe Text
180getThunkGitBranch :: ThunkPtr -> Maybe Text
@@ -150,26 +182,26 @@ getThunkGitBranch (ThunkPtr _ src) = fmap untagName $ case src of
150 ThunkSource_GitHub s -> _gitHubSource_branch s
182 ThunkSource_GitHub s -> _gitHubSource_branch s
151 ThunkSource_Git s -> _gitSource_branch s
183 ThunkSource_Git s -> _gitSource_branch s
153−commitNameToRef :: Name Commit -> Ref
185+commitNameToRef :: Name Commit -> Ref Ref.SHA1
154commitNameToRef (N c) = Ref.fromHex $ encodeUtf8 c
186commitNameToRef (N c) = Ref.fromHex $ encodeUtf8 c
156-- TODO: Use spinner here.
188-- TODO: Use spinner here.
157getNixSha256ForUriUnpacked
189getNixSha256ForUriUnpacked
158 :: MonadObelisk m
190 :: MonadObelisk m
159− => URI
191+ => GitUri
160 -> m NixSha256
192 -> m NixSha256
161getNixSha256ForUriUnpacked uri =
193getNixSha256ForUriUnpacked 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
163 [hash] <- fmap T.lines $ readProcessAndLogOutput (Debug, Debug) $
195 [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]
165 pure hash
197 pure hash
167−nixPrefetchGit :: MonadObelisk m => URI -> Text -> Bool -> m NixSha256
199+nixPrefetchGit :: MonadObelisk m => GitUri -> Text -> Bool -> m NixSha256
168nixPrefetchGit uri rev fetchSubmodules =
200nixPrefetchGit 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
170 out <- readProcessAndLogStderr Debug $
202 out <- readProcessAndLogStderr Debug $
171 proc "nix-prefetch-git" $ filter (/="")
203 proc "nix-prefetch-git" $ filter (/="")
172− [ "--url", T.unpack $ render uri
204+ [ "--url", T.unpack $ gitUriToText uri
173 , "--rev", T.unpack rev
205 , "--rev", T.unpack rev
174 , if fetchSubmodules then "--fetch-submodules" else ""
206 , if fetchSubmodules then "--fetch-submodules" else ""
175 , "--quiet"
207 , "--quiet"
@@ -200,6 +232,9 @@ readThunk thunkDir = do
200 False -> return $ return Nothing
232 False -> return $ return Nothing
201 False -> liftIO $ fmap ThunkData_Packed <$> readPackedThunk thunkDir
233 False -> liftIO $ fmap ThunkData_Packed <$> readPackedThunk thunkDir
235+attrCacheFileName :: FilePath
236+attrCacheFileName = ".attr-cache"
203data ThunkType = ThunkType
238data ThunkType = ThunkType
204 { _thunkType_loader :: FilePath
239 { _thunkType_loader :: FilePath
205 , _thunkType_json :: FilePath
240 , _thunkType_json :: FilePath
@@ -212,7 +247,7 @@ gitHubThunkType :: ThunkType
212gitHubThunkType = ThunkType
247gitHubThunkType = ThunkType
213 { _thunkType_loader = "default.nix"
248 { _thunkType_loader = "default.nix"
214 , _thunkType_json = "github.json"
249 , _thunkType_json = "github.json"
215− , _thunkType_optional = Set.fromList [".attr-cache"]
250+ , _thunkType_optional = Set.fromList [attrCacheFileName]
216 , _thunkType_loaderVersions = gitHubStandaloneLoaders
251 , _thunkType_loaderVersions = gitHubStandaloneLoaders
217 , _thunkType_parser = parseThunkPtr $ \v ->
252 , _thunkType_parser = parseThunkPtr $ \v ->
218 ThunkSource_GitHub <$> parseGitHubSource v <|> ThunkSource_Git <$> parseGitSource v
253 ThunkSource_GitHub <$> parseGitHubSource v <|> ThunkSource_Git <$> parseGitSource v
@@ -222,7 +257,7 @@ gitThunkType :: ThunkType
222gitThunkType = ThunkType
257gitThunkType = ThunkType
223 { _thunkType_loader = "default.nix"
258 { _thunkType_loader = "default.nix"
224 , _thunkType_json = "git.json"
259 , _thunkType_json = "git.json"
225− , _thunkType_optional = Set.fromList [".attr-cache"]
260+ , _thunkType_optional = Set.fromList [attrCacheFileName]
226 , _thunkType_loaderVersions = plainGitStandaloneLoaders
261 , _thunkType_loaderVersions = plainGitStandaloneLoaders
227 , _thunkType_parser = parseThunkPtr $ fmap ThunkSource_Git . parseGitSource
262 , _thunkType_parser = parseThunkPtr $ fmap ThunkSource_Git . parseGitSource
@@ -287,10 +322,12 @@ parseGitHubSource v = do
287 owner <- v Aeson..: "owner"
322 owner <- v Aeson..: "owner"
288 repo <- v Aeson..: "repo"
323 repo <- v Aeson..: "repo"
289 branch <- v Aeson..:! "branch"
324 branch <- v Aeson..:! "branch"
325+ private <- v Aeson..:? "private"
290 pure $ GitHubSource
326 pure $ GitHubSource
291 { _gitHubSource_owner = owner
327 { _gitHubSource_owner = owner
292 , _gitHubSource_repo = repo
328 , _gitHubSource_repo = repo
293 , _gitHubSource_branch = branch
329 , _gitHubSource_branch = branch
330+ , _gitHubSource_private = fromMaybe False private
296parseGitSource :: Aeson.Object -> Aeson.Parser GitSource
333parseGitSource :: Aeson.Object -> Aeson.Parser GitSource
@@ -298,10 +335,12 @@ parseGitSource v = do
298 Just url <- parseGitUri <$> v Aeson..: "url"
335 Just url <- parseGitUri <$> v Aeson..: "url"
299 branch <- v Aeson..:! "branch"
336 branch <- v Aeson..:! "branch"
300 fetchSubmodules <- v Aeson..:! "fetchSubmodules"
337 fetchSubmodules <- v Aeson..:! "fetchSubmodules"
338+ private <- v Aeson..:? "private"
301 pure $ GitSource
339 pure $ GitSource
302 { _gitSource_url = url
340 { _gitSource_url = url
303 , _gitSource_branch = branch
341 , _gitSource_branch = branch
304 , _gitSource_fetchSubmodules = fromMaybe False fetchSubmodules
342 , _gitSource_fetchSubmodules = fromMaybe False fetchSubmodules
343+ , _gitSource_private = fromMaybe False private
307overwriteThunk :: MonadObelisk m => FilePath -> ThunkPtr -> m ()
346overwriteThunk :: MonadObelisk m => FilePath -> ThunkPtr -> m ()
@@ -328,13 +367,15 @@ encodeThunkPtrData (ThunkPtr rev src) = case src of
328 , ("branch" .=) <$> _gitHubSource_branch s
367 , ("branch" .=) <$> _gitHubSource_branch s
329 , Just $ "rev" .= Ref.toHexString (_thunkRev_commit rev)
368 , Just $ "rev" .= Ref.toHexString (_thunkRev_commit rev)
330 , Just $ "sha256" .= _thunkRev_nixSha256 rev
369 , Just $ "sha256" .= _thunkRev_nixSha256 rev
370+ , Just $ "private" .= _gitHubSource_private s
332 ThunkSource_Git s -> encodePretty' plainGitCfg $ Aeson.object $ catMaybes
372 ThunkSource_Git s -> encodePretty' plainGitCfg $ Aeson.object $ catMaybes
333− [ Just $ "url" .= render (_gitSource_url s)
373+ [ Just $ "url" .= gitUriToText (_gitSource_url s)
334 , Just $ "rev" .= Ref.toHexString (_thunkRev_commit rev)
374 , Just $ "rev" .= Ref.toHexString (_thunkRev_commit rev)
335 , ("branch" .=) <$> _gitSource_branch s
375 , ("branch" .=) <$> _gitSource_branch s
336 , Just $ "sha256" .= _thunkRev_nixSha256 rev
376 , Just $ "sha256" .= _thunkRev_nixSha256 rev
337 , Just $ "fetchSubmodules" .= _gitSource_fetchSubmodules s
377 , Just $ "fetchSubmodules" .= _gitSource_fetchSubmodules s
378+ , Just $ "private" .= _gitSource_private s
340 githubCfg = defConfig
381 githubCfg = defConfig
@@ -355,6 +396,7 @@ encodeThunkPtrData (ThunkPtr rev src) = case src of
357 , "sha256"
398 , "sha256"
358 , "fetchSubmodules"
400 , "fetchSubmodules"
359 ] <> compare
401 ] <> compare
360 , confTrailingNewline = True
402 , confTrailingNewline = True
@@ -362,7 +404,7 @@ encodeThunkPtrData (ThunkPtr rev src) = case src of
363createThunk :: MonadIO m => FilePath -> ThunkPtr -> m ()
405createThunk :: MonadIO m => FilePath -> ThunkPtr -> m ()
364createThunk target thunk = liftIO $ do
406createThunk target thunk = liftIO $ do
365− createDirectoryIfMissing True (target </> ".attr-cache")
407+ createDirectoryIfMissing True (target </> attrCacheFileName)
366 T.writeFile (target </> "default.nix") (thunkPtrLoader thunk)
408 T.writeFile (target </> "default.nix") (thunkPtrLoader thunk)
368 jsonFileName = case _thunkPtr_source thunk of
410 jsonFileName = case _thunkPtr_source thunk of
@@ -378,8 +420,8 @@ createThunkWithLatest target s = do
378 , _thunkPtr_rev = rev
420 , _thunkPtr_rev = rev
381−updateThunkToLatest :: MonadObelisk m => FilePath -> Maybe String -> m ()
423+updateThunkToLatest :: MonadObelisk m => ThunkUpdateConfig -> FilePath -> m ()
382−updateThunkToLatest target mBranch = withSpinner' ("Updating thunk " <> T.pack target <> " to latest") (pure $ const $ "Thunk " <> T.pack target <> " updated to latest") $ do
424+updateThunkToLatest (ThunkUpdateConfig mBranch thunkConfig) target = withSpinner' ("Updating thunk " <> T.pack target <> " to latest") (pure $ const $ "Thunk " <> T.pack target <> " updated to latest") $ do
383 checkThunkDirectory "ob thunk update directory cannot be '.'" target
425 checkThunkDirectory "ob thunk update directory cannot be '.'" target
384 -- check to see if thunk should be updated to a specific branch or just update it's current branch
426 -- check to see if thunk should be updated to a specific branch or just update it's current branch
385 case mBranch of
427 case mBranch of
@@ -391,7 +433,7 @@ updateThunkToLatest target mBranch = withSpinner' ("Updating thunk " <> T.pack t
391 ThunkData_Checkout _ -> failWith "cannot update an unpacked thunk"
433 ThunkData_Checkout _ -> failWith "cannot update an unpacked thunk"
392 let src = _thunkPtr_source ptr
434 let src = _thunkPtr_source ptr
393 rev <- getLatestRev src
435 rev <- getLatestRev src
394− overwriteThunk overwrite $ ThunkPtr
436+ overwriteThunk overwrite $ modifyThunkPtrByConfig thunkConfig $ ThunkPtr
395 { _thunkPtr_source = src
437 { _thunkPtr_source = src
396 , _thunkPtr_rev = rev
438 , _thunkPtr_rev = rev
@@ -399,24 +441,25 @@ updateThunkToLatest target mBranch = withSpinner' ("Updating thunk " <> T.pack t
399 Left err -> failWith $ T.pack $ "thunk update: " <> show err
441 Left err -> failWith $ T.pack $ "thunk update: " <> show err
400 Right c -> case c of
442 Right c -> case c of
401 ThunkData_Packed t -> case _thunkPtr_source t of
443 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
403 ThunkSource_GitHub tsgh -> do
445 ThunkSource_GitHub tsgh -> do
404 let tsg = forgetGithub False tsgh
446 let tsg = forgetGithub False tsgh
405− setThunk target tsg branch
447+ setThunk thunkConfig 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."
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."
408−setThunk :: MonadObelisk m => FilePath -> GitSource -> String -> m ()
450+setThunk :: MonadObelisk m => ThunkConfig -> FilePath -> GitSource -> String -> m ()
409−setThunk target gs branch = do
451+setThunk thunkConfig target gs branch = do
410− newThunkPtr <- uriThunkPtr (_gitSource_url gs) (Just $ T.pack branch) Nothing
452+ newThunkPtr <- uriThunkPtr (_gitSource_url gs) (_thunkConfig_private thunkConfig) (Just $ T.pack branch) Nothing
411 overwriteThunk target newThunkPtr
453 overwriteThunk target newThunkPtr
412− updateThunkToLatest target Nothing
454+ updateThunkToLatest (ThunkUpdateConfig Nothing thunkConfig) target
414-- | All recognized github standalone loaders, ordered from newest to oldest.
456-- | All recognized github standalone loaders, ordered from newest to oldest.
415-- This tool will only ever produce the newest one when it writes a thunk.
457-- This tool will only ever produce the newest one when it writes a thunk.
416gitHubStandaloneLoaders :: NonEmpty Text
458gitHubStandaloneLoaders :: NonEmpty Text
417gitHubStandaloneLoaders =
459gitHubStandaloneLoaders =
418− gitHubStandaloneLoaderV2 :|
460+ gitHubStandaloneLoaderV4 :|
419 [ gitHubStandaloneLoaderV3
461 [ gitHubStandaloneLoaderV3
462+ , gitHubStandaloneLoaderV2
420 , gitHubStandaloneLoaderV1
463 , gitHubStandaloneLoaderV1
@@ -456,10 +499,24 @@ gitHubStandaloneLoaderV3 = T.unlines
456 , "in import (fetch (builtins.fromJSON (builtins.readFile ./github.json)))"
499 , "in import (fetch (builtins.fromJSON (builtins.readFile ./github.json)))"
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;"
511+ , "in import (fetch (builtins.fromJSON (builtins.readFile ./github.json)))"
459plainGitStandaloneLoaders :: NonEmpty Text
514plainGitStandaloneLoaders :: NonEmpty Text
460plainGitStandaloneLoaders =
515plainGitStandaloneLoaders =
461− plainGitStandaloneLoaderV1 :|
516+ plainGitStandaloneLoaderV4 :|
462− [ plainGitStandaloneLoaderV2
517+ [ plainGitStandaloneLoaderV1
518+ , plainGitStandaloneLoaderV2
519+ , plainGitStandaloneLoaderV3
465plainGitStandaloneLoaderV1 :: Text
522plainGitStandaloneLoaderV1 :: Text
@@ -480,6 +537,41 @@ plainGitStandaloneLoaderV2 = T.unlines
480 , "in import (fetchGit (builtins.fromJSON (builtins.readFile ./git.json)))"
537 , "in import (fetchGit (builtins.fromJSON (builtins.readFile ./git.json)))"
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"
550+ , " in if !fetchSubmodules && private then builtins.fetchGit {"
551+ , " url = realUrl; inherit rev;"
552+ , " } else (import <nixpkgs> {}).fetchgit {"
553+ , " url = realUrl; inherit rev sha256;"
555+ , "in import (fetch (builtins.fromJSON (builtins.readFile ./git.json)))"
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"
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;"
572+ , "in import (fetch (builtins.fromJSON (builtins.readFile ./git.json)))"
483thunkFileNames :: [FilePath]
575thunkFileNames :: [FilePath]
484thunkFileNames = ["default.nix", "github.json", "git.json"]
576thunkFileNames = ["default.nix", "github.json", "git.json"]
@@ -506,7 +598,7 @@ nixBuildThunkAttrWithCache thunkDir attr = do
506 let cacheErrHandler e
598 let cacheErrHandler e
507 | isDoesNotExistError e = return Nothing -- expected from a cache miss
599 | isDoesNotExistError e = return Nothing -- expected from a cache miss
508 | otherwise = putLog Error (T.pack $ displayException e) >> return Nothing
600 | otherwise = putLog Error (T.pack $ displayException e) >> return Nothing
509− cacheDir = thunkDir </> ".attr-cache"
601+ cacheDir = thunkDir </> attrCacheFileName
510 cachePath = cacheDir </> attr <.> "out"
602 cachePath = cacheDir </> attr <.> "out"
511 latestChange <- liftIO $ do
603 latestChange <- liftIO $ do
512 createDirectoryIfMissing False cacheDir
604 createDirectoryIfMissing False cacheDir
@@ -521,7 +613,7 @@ nixBuildThunkAttrWithCache thunkDir attr = do
521 Just c -> return c
613 Just c -> return c
522 Nothing -> do
614 Nothing -> do
523 putLog Warning $ T.pack $ mconcat [thunkDir, ": ", attr, " not cached, building ..."]
615 putLog Warning $ T.pack $ mconcat [thunkDir, ": ", attr, " not cached, building ..."]
524− _ <- nixCmd $ NixCmd_Build$ def
616+ _ <- nixCmd $ NixCmd_Build $ def
525 Lens.& nixBuildConfig_outLink Lens..~ OutLink_IndirectRoot cachePath
617 Lens.& nixBuildConfig_outLink Lens..~ OutLink_IndirectRoot cachePath
526 Lens.& nixCmdConfig_target Lens..~ Target
618 Lens.& nixCmdConfig_target Lens..~ Target
527 { _target_path = Just thunkDir
619 { _target_path = Just thunkDir
@@ -569,13 +661,13 @@ updateThunk p f = withSystemTempDirectory "obelisk-thunkptr-" $ \tmpDir -> do
569 Right (ThunkData_Packed _) -> do
661 Right (ThunkData_Packed _) -> do
570 let tmpThunk = tmpDir </> "thunk"
662 let tmpThunk = tmpDir </> "thunk"
571 callProcessAndLogOutput (Notice, Error) $
663 callProcessAndLogOutput (Notice, Error) $
572− proc "cp" ["-r", "-T", thunkDir, tmpThunk]
664+ proc cp ["-r", "-T", thunkDir, tmpThunk]
573 return tmpThunk
665 return tmpThunk
574− Right _ -> failWith $ "Thunk is not packed"
666+ Right _ -> failWith "Thunk is not packed"
575 updateThunkFromTmp p' = do
667 updateThunkFromTmp p' = do
576− _ <- packThunk' True p'
668+ _ <- packThunk' True (ThunkPackConfig False (ThunkConfig Nothing)) p'
577 callProcessAndLogOutput (Notice, Error) $
669 callProcessAndLogOutput (Notice, Error) $
578− proc "cp" ["-r", "-T", p', p]
670+ proc cp ["-r", "-T", p', p]
580finalMsg :: Bool -> (a -> Text) -> Maybe (a -> Text)
672finalMsg :: Bool -> (a -> Text) -> Maybe (a -> Text)
581finalMsg noTrail s = if noTrail then Nothing else Just s
673finalMsg noTrail s = if noTrail then Nothing else Just s
@@ -607,7 +699,7 @@ unpackThunk' noTrail thunkDir = checkThunkDirectory "Can't pack/unpack from with
607 let git = callProcessAndLogOutput (Notice, Notice) . gitProc tmpRepo
699 let git = callProcessAndLogOutput (Notice, Notice) . gitProc tmpRepo
608 git $ [ "clone" ]
700 git $ [ "clone" ]
609 ++ ("--recursive" <$ guard (_gitSource_fetchSubmodules s))
701 ++ ("--recursive" <$ guard (_gitSource_fetchSubmodules s))
610− ++ [ T.unpack $ render $ _gitSource_url s ]
702+ ++ [ T.unpack $ gitUriToText $ _gitSource_url s ]
611 ++ do branch <- maybeToList $ _gitSource_branch s
703 ++ do branch <- maybeToList $ _gitSource_branch s
612 [ "--branch", T.unpack $ untagName branch ]
704 [ "--branch", T.unpack $ untagName branch ]
613 git ["reset", "--hard", Ref.toHexString $ _thunkRev_commit $ _thunkPtr_rev tptr]
705 git ["reset", "--hard", Ref.toHexString $ _thunkRev_commit $ _thunkPtr_rev tptr]
@@ -616,35 +708,39 @@ unpackThunk' noTrail thunkDir = checkThunkDirectory "Can't pack/unpack from with
617 liftIO $ createDirectory obGitDir
709 liftIO $ createDirectory obGitDir
618 callProcessAndLogOutput (Notice, Error) $
710 callProcessAndLogOutput (Notice, Error) $
619− proc "cp" ["-r", "-T", thunkDir </> ".", obGitDir </> "orig-thunk"]
711+ proc cp ["-r", "-T", thunkDir </> ".", obGitDir </> "orig-thunk"]
620 callProcessAndLogOutput (Notice, Error) $
712 callProcessAndLogOutput (Notice, Error) $
621 proc "rm" ["-r", thunkDir]
713 proc "rm" ["-r", thunkDir]
622 callProcessAndLogOutput (Notice, Error) $
714 callProcessAndLogOutput (Notice, Error) $
623 proc "mv" ["-T", tmpRepo, thunkDir]
715 proc "mv" ["-T", tmpRepo, thunkDir]
625−--TODO: add force mode to pack even if changes are present
626--TODO: add a rollback mode to pack to the original thunk
717--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
628packThunk = packThunk' False
719packThunk = packThunk' False
630−packThunk' :: MonadObelisk m => Bool -> FilePath -> m ThunkPtr
721+packThunk' :: MonadObelisk m => Bool -> ThunkPackConfig -> FilePath -> m ThunkPtr
631−packThunk' noTrail thunkDir = checkThunkDirectory "Can't pack/unpack from within the thunk directory" thunkDir >> readThunk thunkDir >>= \case
722+packThunk' noTrail (ThunkPackConfig force thunkConfig) thunkDir = checkThunkDirectory "Can't pack/unpack from within the thunk directory" thunkDir >> readThunk thunkDir >>= \case
632 Left err -> failWith $ T.pack $ "thunk pack: " <> show err
723 Left err -> failWith $ T.pack $ "thunk pack: " <> show err
633 Right (ThunkData_Packed _) -> failWith "pack: thunk is already packed"
724 Right (ThunkData_Packed _) -> failWith "pack: thunk is already packed"
634 Right (ThunkData_Checkout _) -> do
725 Right (ThunkData_Checkout _) -> do
635 withSpinner' ("Packing thunk " <> T.pack thunkDir)
726 withSpinner' ("Packing thunk " <> T.pack thunkDir)
636 (finalMsg noTrail $ const $ "Packed thunk " <> T.pack thunkDir) $ do
727 (finalMsg noTrail $ const $ "Packed thunk " <> T.pack thunkDir) $ do
637− thunkPtr <- getThunkPtr thunkDir
728+ thunkPtr <- modifyThunkPtrByConfig thunkConfig <$> getThunkPtr (not force) thunkDir (_thunkConfig_private thunkConfig)
638 callProcessAndLogOutput (Debug, Error) $ proc "rm" ["-rf", thunkDir]
729 callProcessAndLogOutput (Debug, Error) $ proc "rm" ["-rf", thunkDir]
639 liftIO $ createThunk thunkDir thunkPtr
730 liftIO $ createThunk thunkDir thunkPtr
640 pure thunkPtr
731 pure thunkPtr
642−getThunkPtr :: MonadObelisk m => FilePath -> m ThunkPtr
733+modifyThunkPtrByConfig :: ThunkConfig -> ThunkPtr -> ThunkPtr
643−getThunkPtr = getThunkPtr' True
734+modifyThunkPtrByConfig (ThunkConfig markPrivate') ptr = case markPrivate' of
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 }
645−getThunkPtr' :: forall m. MonadObelisk m => Bool -> FilePath -> m ThunkPtr
741+getThunkPtr :: forall m. MonadObelisk m => Bool -> FilePath -> Maybe Bool -> m ThunkPtr
646−getThunkPtr' checkClean thunkDir = do
742+getThunkPtr checkClean thunkDir mPrivate = do
647− when checkClean $ ensureCleanGitRepo thunkDir True $
743+ when checkClean $ ensureCleanGitRepo thunkDir True
648 "thunk pack: thunk checkout contains unsaved modifications"
744 "thunk pack: thunk checkout contains unsaved modifications"
650 -- Check whether there are any stashes
746 -- Check whether there are any stashes
@@ -657,7 +753,7 @@ getThunkPtr' checkClean thunkDir = do
657 ] ++ T.lines stashOutput
753 ] ++ T.lines stashOutput
658 True -> return ()
754 True -> return ()
660− -- Get current branch ``
756+ -- Get current branch
661 (mCurrentBranch, mCurrentCommit) <- do
757 (mCurrentBranch, mCurrentCommit) <- do
662 b <- listToMaybe
758 b <- listToMaybe
663 <$> T.lines
759 <$> T.lines
@@ -666,7 +762,7 @@ getThunkPtr' checkClean thunkDir = do
666 <$> T.lines
762 <$> T.lines
667 <$> readGitProcess thunkDir ["rev-parse", "HEAD"]
763 <$> readGitProcess thunkDir ["rev-parse", "HEAD"]
668 case b of
764 case b of
669− (Just "HEAD") -> failWith $ T.unlines $
765+ (Just "HEAD") -> failWith $ T.unlines
670 [ "thunk pack: You are in 'detached HEAD' state."
766 [ "thunk pack: You are in 'detached HEAD' state."
671 , "If you want to pack at the current ref \
767 , "If you want to pack at the current ref \
672 \then please create a new branch with 'git checkout -b <new-branch-name>' and push this upstream."
768 \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
738 [ "thunk pack: Certain branches in the thunk have commits not yet pushed upstream:"
834 [ "thunk pack: Certain branches in the thunk have commits not yet pushed upstream:"
741− (flip map (Map.toList nonGood) $ \(branch, (upstream, (ahead, behind))) -> mconcat
837+ flip map (Map.toList nonGood) (\(branch, (upstream, (ahead, behind))) -> mconcat
742 [" ", branch, " ahead: ", T.pack (show ahead), " behind: ", T.pack (show behind), " remote branch ", upstream]) ++
838 [" ", branch, " ahead: ", T.pack (show ahead), " behind: ", T.pack (show behind), " remote branch ", upstream]) ++
744 , "Please push these upstream and try again. (Or just fetch, if they are somehow \
840 , "Please push these upstream and try again. (Or just fetch, if they are somehow \
@@ -746,7 +842,7 @@ getThunkPtr' checkClean thunkDir = do
748 -- We assume it's safe to pack the thunk at this point
844 -- 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."
751 let remote = maybe "origin" snd $ flip Map.lookup headUpstream =<< mCurrentBranch
847 let remote = maybe "origin" snd $ flip Map.lookup headUpstream =<< mCurrentBranch
@@ -759,7 +855,7 @@ getThunkPtr' checkClean thunkDir = do
759 remoteUri <- case parseGitUri remoteUri' of
855 remoteUri <- case parseGitUri remoteUri' of
760 Nothing -> failWith $ "Could not identify git remote: " <> remoteUri'
856 Nothing -> failWith $ "Could not identify git remote: " <> remoteUri'
761 Just uri -> pure uri
857 Just uri -> pure uri
762− uriThunkPtr remoteUri mCurrentBranch mCurrentCommit
858+ uriThunkPtr remoteUri mPrivate mCurrentBranch mCurrentCommit
764-- | Get the latest revision available from the given source
860-- | Get the latest revision available from the given source
765getLatestRev :: MonadObelisk m => ThunkSource -> m ThunkRev
861getLatestRev :: MonadObelisk m => ThunkSource -> m ThunkRev
@@ -778,18 +874,18 @@ getLatestRev os = do
778-- performance. If that doesn't work (e.g. authentication issue), we fall back
874-- performance. If that doesn't work (e.g. authentication issue), we fall back
779-- on just doing things the normal way for git repos in general, and save it as
875-- on just doing things the normal way for git repos in general, and save it as
780-- a regular git thunk.
876-- a regular git thunk.
781−uriThunkPtr :: MonadObelisk m => URI -> Maybe Text -> Maybe Text -> m ThunkPtr
877+uriThunkPtr :: MonadObelisk m => GitUri -> Maybe Bool -> Maybe Text -> Maybe Text -> m ThunkPtr
782−uriThunkPtr uri mbranch mcommit = do
878+uriThunkPtr uri mPrivate mbranch mcommit = do
783 commit <- case mcommit of
879 commit <- case mcommit of
784 Nothing -> gitGetCommitBranch uri mbranch >>= return . snd
880 Nothing -> gitGetCommitBranch uri mbranch >>= return . snd
785 (Just c) -> return c
881 (Just c) -> return c
786− (src, rev) <- case uriToThunkSource uri mbranch of
882+ (src, rev) <- uriToThunkSource uri mPrivate mbranch >>= \case
787 ThunkSource_GitHub s -> do
883 ThunkSource_GitHub s -> do
788 rev <- runExceptT $ githubThunkRev s commit
884 rev <- runExceptT $ githubThunkRev s commit
789 case rev of
885 case rev of
790 Right r -> pure (ThunkSource_GitHub s, r)
886 Right r -> pure (ThunkSource_GitHub s, r)
791 Left e -> do
887 Left e -> do
792− putLog Warning $ "\
888+ putLog Warning "\
793\Failed to fetch archive from GitHub. This is probably a private repo. \
889\Failed to fetch archive from GitHub. This is probably a private repo. \
794\Falling back on normal fetchgit. Original failure:"
890\Falling back on normal fetchgit. Original failure:"
795 errorToWarning e
891 errorToWarning e
@@ -806,34 +902,66 @@ uriThunkPtr uri mbranch mcommit = do
806-- If the thunk is a GitHub thunk and fails, we do *not* fall back like with
902-- If the thunk is a GitHub thunk and fails, we do *not* fall back like with
807-- `uriThunkPtr`. Unlike a plain URL, a thunk src explicitly states which method
903-- `uriThunkPtr`. Unlike a plain URL, a thunk src explicitly states which method
808-- should be employed, and so we respect that.
904-- should be employed, and so we respect that.
809−uriToThunkSource :: URI -> Maybe Text -> ThunkSource
905+uriToThunkSource :: MonadObelisk m => GitUri -> Maybe Bool -> Maybe Text -> m ThunkSource
810−uriToThunkSource u
906+uriToThunkSource (GitUri u) mPrivate
811− | Right uriAuth <- uriAuthority u
907+ | Right uriAuth <- URI.uriAuthority u
812− , Just scheme <- unRText <$> uriScheme u
908+ , Just scheme <- URI.unRText <$> URI.uriScheme u
813 , case scheme of
909 , case scheme of
814− "ssh" -> uriAuth == Authority
910+ "ssh" -> uriAuth == URI.Authority
815− { authUserInfo = Just $ UserInfo (fromRight' $ mkUsername "git") Nothing
911+ { URI.authUserInfo = Just $ URI.UserInfo (fromRight' $ URI.mkUsername "git") Nothing
816− , authHost = fromRight' $ mkHost "github.com"
912+ , URI.authHost = fromRight' $ URI.mkHost "github.com"
817− , authPort = Nothing
913+ , URI.authPort = Nothing
819 s -> s `L.elem` [ "git", "https", "http" ] -- "http:" just redirects to "https:"
915 s -> s `L.elem` [ "git", "https", "http" ] -- "http:" just redirects to "https:"
820− && unRText (authHost uriAuth) == "github.com"
916+ && URI.unRText (URI.authHost uriAuth) == "github.com"
821− , Just (_, owner :| [repoish]) <- uriPath u
917+ , Just (_, owner :| [repoish]) <- URI.uriPath u
822− = \mbranch -> ThunkSource_GitHub $ GitHubSource
918+ = \mbranch -> do
823− { _gitHubSource_owner = N $ unRText owner
919+ isPrivate <- getIsPrivate
824− , _gitHubSource_repo = N $ let
920+ pure $ ThunkSource_GitHub $ GitHubSource
825− repoish' = unRText repoish
921+ { _gitHubSource_owner = N $ URI.unRText owner
826− in case T.stripSuffix ".git" repoish' of
922+ , _gitHubSource_repo = N $ let
827− Just repo -> repo
923+ repoish' = URI.unRText repoish
828− Nothing -> repoish'
924+ in fromMaybe repoish' $ T.stripSuffix ".git" repoish'
829− , _gitHubSource_branch = N <$> mbranch
925+ , _gitHubSource_branch = N <$> mbranch
830− }
926+ , _gitHubSource_private = isPrivate
832− | otherwise = \mbranch -> ThunkSource_Git $ GitSource
929+ | otherwise = \mbranch -> do
833− { _gitSource_url = u
930+ isPrivate <- getIsPrivate
834− , _gitSource_branch = N <$> mbranch
931+ pure $ ThunkSource_Git $ GitSource
835− , _gitSource_fetchSubmodules = False -- TODO: How do we determine if this should be true?
932+ { _gitSource_url = GitUri u
836− }
933+ , _gitSource_branch = N <$> mbranch
934+ , _gitSource_fetchSubmodules = False -- TODO: How do we determine if this should be true?
935+ , _gitSource_private = isPrivate
938+ getIsPrivate = maybe (guessGitRepoIsPrivate $ GitUri u) pure mPrivate
940+guessGitRepoIsPrivate :: MonadObelisk m => GitUri -> m Bool
941+guessGitRepoIsPrivate uri = flip fix urisToTry $ \loop -> \case
944+ result <- readCreateProcessWithExitCode $
951+ , T.unpack $ gitUriToText uriAttempt
954+ (ExitSuccess, _, _) -> pure False -- Must be a public repo
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
838-- Funny signature indicates no effects depend on the optional branch name.
966-- Funny signature indicates no effects depend on the optional branch name.
839githubThunkRev
967githubThunkRev
@@ -845,19 +973,19 @@ githubThunkRev
845githubThunkRev s commit = do
973githubThunkRev s commit = do
846 owner <- forcePP $ _gitHubSource_owner s
974 owner <- forcePP $ _gitHubSource_owner s
847 repo <- forcePP $ _gitHubSource_repo s
975 repo <- forcePP $ _gitHubSource_repo s
848− revTarball <- mkPathPiece $ commit <> ".tar.gz"
976+ revTarball <- URI.mkPathPiece $ commit <> ".tar.gz"
849− let archiveUri = URI
977+ let archiveUri = GitUri $ URI.URI
850− { uriScheme = Just $ fromRight' $ mkScheme "https"
978+ { URI.uriScheme = Just $ fromRight' $ URI.mkScheme "https"
851− , uriAuthority = Right $ Authority
979+ , URI.uriAuthority = Right $ URI.Authority
852− { authUserInfo = Nothing
980+ { URI.authUserInfo = Nothing
853− , authHost = fromRight' $ mkHost "github.com"
981+ , URI.authHost = fromRight' $ URI.mkHost "github.com"
854− , authPort = Nothing
982+ , URI.authPort = Nothing
856− , uriPath = Just ( False
984+ , URI.uriPath = Just ( False
857− , owner :| [ repo, fromRight' $ mkPathPiece "archive", revTarball ]
985+ , owner :| [ repo, fromRight' $ URI.mkPathPiece "archive", revTarball ]
859− , uriQuery = []
987+ , URI.uriQuery = []
860− , uriFragment = Nothing
988+ , URI.uriFragment = Nothing
862 hash <- getNixSha256ForUriUnpacked archiveUri
990 hash <- getNixSha256ForUriUnpacked archiveUri
863 putLog Debug $ "Nix sha256 is " <> hash
991 putLog Debug $ "Nix sha256 is " <> hash
@@ -866,8 +994,8 @@ githubThunkRev s commit = do
866 , _thunkRev_nixSha256 = hash
994 , _thunkRev_nixSha256 = hash
869− forcePP :: Name entity -> m (RText 'PathPiece)
997+ forcePP :: Name entity -> m (URI.RText 'URI.PathPiece)
870− forcePP = mkPathPiece . untagName
998+ forcePP = URI.mkPathPiece . untagName
872gitThunkRev
1000gitThunkRev
873 :: MonadObelisk m
1001 :: MonadObelisk m
@@ -876,11 +1004,11 @@ gitThunkRev
876 -> m ThunkRev
1004 -> m ThunkRev
877gitThunkRev s commit = do
1005gitThunkRev s commit = do
878 let u = _gitSource_url s
1006 let u = _gitSource_url s
879− protocols = ["https", "ssh", "git"]
1007+ protocols = ["file", "https", "ssh", "git"]
880− Just scheme <- pure $ unRText <$> uriScheme u
1008+ scheme = maybe "file" URI.unRText $ URI.uriScheme $ (\(GitUri x) -> x) u
881 unless (T.toLower scheme `elem` protocols) $
1009 unless (T.toLower scheme `elem` protocols) $
882 failWith $ "obelisk currently only supports "
1010 failWith $ "obelisk currently only supports "
883− <> T.intercalate ", " protocols <> " protocols for non-GitHub remotes"
1011+ <> T.intercalate ", " protocols <> " protocols for plain Git remotes"
884 hash <- nixPrefetchGit u commit $ _gitSource_fetchSubmodules s
1012 hash <- nixPrefetchGit u commit $ _gitSource_fetchSubmodules s
885 putLog Informational $ "Nix sha256 is " <> hash
1013 putLog Informational $ "Nix sha256 is " <> hash
886 pure $ ThunkRev
1014 pure $ ThunkRev
@@ -893,11 +1021,12 @@ gitThunkRev s commit = do
894-- If the branch name is passed in, it is returned exactly as-is. If it is not
1022-- If the branch name is passed in, it is returned exactly as-is. If it is not
895-- passed it, the default branch of the repo is used instead.
1023-- passed it, the default branch of the repo is used instead.
896gitGetCommitBranch
1025gitGetCommitBranch
897− :: MonadObelisk m => URI -> Maybe Text -> m (Text, CommitId)
1026+ :: MonadObelisk m => GitUri -> Maybe Text -> m (Text, CommitId)
898gitGetCommitBranch uri mbranch = withExitFailMessage ("Failure for git remote " <> uriMsg) $ do
1027gitGetCommitBranch uri mbranch = withExitFailMessage ("Failure for git remote " <> uriMsg) $ do
899 (_, bothMaps) <- gitLsRemote
1028 (_, bothMaps) <- gitLsRemote
900− (T.unpack $ render uri)
1029+ (T.unpack $ gitUriToText uri)
901 (GitRef_Branch <$> mbranch)
1030 (GitRef_Branch <$> mbranch)
903 branch <- case mbranch of
1032 branch <- case mbranch of
@@ -913,18 +1042,21 @@ gitGetCommitBranch uri mbranch = withExitFailMessage ("Failure for git remote "
913 pure (branch, commit)
1042 pure (branch, commit)
915 rethrowE = either failWith pure
1044 rethrowE = either failWith pure
916− uriMsg = render uri
1045+ uriMsg = gitUriToText uri
1047+parseGitUri :: Text -> Maybe GitUri
1048+parseGitUri x = GitUri <$> (parseFileURI x <|> parseAbsoluteURI x <|> parseSshShorthand x)
918−parseGitUri :: Text -> Maybe URI
1050+parseFileURI :: Text -> Maybe URI.URI
919−parseGitUri x = parseAbsoluteURI x <|> parseSshShorthand x
1051+parseFileURI uri = if "/" `T.isPrefixOf` uri then parseAbsoluteURI ("file://" <> uri) else Nothing
921−parseAbsoluteURI :: Text -> Maybe URI
1053+parseAbsoluteURI :: Text -> Maybe URI.URI
922parseAbsoluteURI uri = do
1054parseAbsoluteURI uri = do
923− parsedUri <- mkURI uri
1055+ parsedUri <- URI.mkURI uri
924− guard $ isPathAbsolute parsedUri
1056+ guard $ URI.isPathAbsolute parsedUri
925− pure $ parsedUri
1057+ pure parsedUri
927−parseSshShorthand :: Text -> Maybe URI
1059+parseSshShorthand :: Text -> Maybe URI.URI
928parseSshShorthand uri = do
1060parseSshShorthand uri = do
929 -- This is what git does to check that the remote
1061 -- This is what git does to check that the remote
930 -- is not a local file path when parsing shorthand.
1062 -- is not a local file path when parsing shorthand.
@@ -937,4 +1069,4 @@ parseSshShorthand uri = do
937 -- This check is used to disambiguate a filepath containing a colon from shorthand
1069 -- This check is used to disambiguate a filepath containing a colon from shorthand
938 guard $ isNothing (T.findIndex (=='/') authAndHostname)
1070 guard $ isNothing (T.findIndex (=='/') authAndHostname)
939 && not (T.null colonAndPath)
1071 && not (T.null colonAndPath)
940− mkURI properUri
1072+ URI.mkURI properUri