@@ -8,25 +8,30 @@
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 (..)
2021 , createThunk
2122 , createThunkWithLatest
23+ , getLatestRev
24+ , getThunkGitBranch
25+ , getThunkPtr
26+ , gitUriToText
2227 , nixBuildAttrWithCache
2328 , nixBuildThunkAttrWithCache
24− , unpackThunk
2529 , packThunk
30+ , parseGitUri
2631 , readThunk
32+ , unpackThunk
2733 , updateThunk
28− , getThunkPtr
29− , parseGitUri
34+ , updateThunkToLatest
3035 , uriThunkPtr
3136 ) where
3237
@@ -68,8 +73,7 @@ import System.FilePath
6873import System.IO.Error
6974import System.IO.Temp
7075import System.Posix (getSymbolicLinkStatus, modificationTime)
71−import System.Process (proc)
72−import Text.URI
76+import qualified Text.URI as URI
7377
7478import Obelisk.App (MonadObelisk)
7579import Obelisk.CliApp
@@ -111,37 +115,63 @@ data GitHubSource = GitHubSource
111115 { _gitHubSource_owner :: Name Owner
112116 , _gitHubSource_repo :: Name Repo
113117 , _gitHubSource_branch :: Maybe (Name Branch)
118+ , _gitHubSource_private :: Bool
114119 }
115120 deriving (Show, Eq, Ord)
116121
122+newtype GitUri = GitUri URI.URI deriving (Eq, Ord, Show)
123+
124+gitUriToText :: GitUri -> Text
125+gitUriToText (GitUri uri)
126+ | (T.toLower . URI.unRText <$> URI.uriScheme uri) == Just "file"
127+ , Just (_, path) <- URI.uriPath uri
128+ = "/" <> T.intercalate "/" (map URI.unRText $ NonEmpty.toList path)
129+ | otherwise = URI.render uri
130+
117131data GitSource = GitSource
118− { _gitSource_url :: URI
132+ { _gitSource_url :: GitUri
119133 , _gitSource_branch :: Maybe (Name Branch)
120134 , _gitSource_fetchSubmodules :: Bool
135+ , _gitSource_private :: Bool
121136 }
122137 deriving (Show, Eq, Ord)
123138
139+newtype ThunkConfig = ThunkConfig
140+ { _thunkConfig_private :: Maybe Bool
141+ } deriving Show
142+
143+data ThunkUpdateConfig = ThunkUpdateConfig
144+ { _thunkUpdateConfig_branch :: Maybe String
145+ , _thunkUpdateConfig_config :: ThunkConfig
146+ } deriving Show
147+
148+data ThunkPackConfig = ThunkPackConfig
149+ { _thunkPackConfig_force :: Bool
150+ , _thunkPackConfig_config :: ThunkConfig
151+ } deriving Show
152+
124153-- | Convert a GitHub source to a regular Git source. Assumes no submodules.
125154forgetGithub :: Bool -> GitHubSource -> GitSource
126155forgetGithub 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
156+ { _gitSource_url = GitUri $ URI.URI
157+ { URI.uriScheme = Just $ fromRight' $ URI.mkScheme $ if useSsh then "ssh" else "https"
158+ , URI.uriAuthority = Right $ URI.Authority
159+ { URI.authUserInfo = URI.UserInfo (fromRight' $ URI.mkUsername "git") Nothing
131160 <$ guard useSsh
132− , authHost = fromRight' $ mkHost "github.com"
133− , authPort = Nothing
161+ , URI.authHost = fromRight' $ URI.mkHost "github.com"
162+ , URI.authPort = Nothing
134163 }
135− , uriPath = Just ( False
136− , fromRight' . mkPathPiece <$>
164+ , URI.uriPath = Just ( False
165+ , fromRight' . URI.mkPathPiece <$>
137166 untagName (_gitHubSource_owner s)
138167 :| [ untagName (_gitHubSource_repo s) <> ".git" ]
139168 )
140− , uriQuery = []
141− , uriFragment = Nothing
169+ , URI.uriQuery = []
170+ , URI.uriFragment = Nothing
142171 }
143172 , _gitSource_branch = _gitHubSource_branch s
144173 , _gitSource_fetchSubmodules = False
174+ , _gitSource_private = _gitHubSource_private s
145175 }
146176
147177getThunkGitBranch :: ThunkPtr -> Maybe Text
@@ -155,20 +185,20 @@ commitNameToRef (N c) = Ref.fromHex $ encodeUtf8 c
155185-- TODO: Use spinner here.
156186getNixSha256ForUriUnpacked
157187 :: MonadObelisk m
158− => URI
188+ => GitUri
159189 -> m NixSha256
160190getNixSha256ForUriUnpacked uri =
161− withExitFailMessage ("nix-prefetch-url: Failed to determine sha256 hash of URL " <> render uri) $ do
191+ withExitFailMessage ("nix-prefetch-url: Failed to determine sha256 hash of URL " <> gitUriToText uri) $ do
162192 [hash] <- fmap T.lines $ readProcessAndLogOutput (Debug, Debug) $
163− proc "nix-prefetch-url" ["--unpack" , "--type" , "sha256" , T.unpack $ render uri]
193+ proc "nix-prefetch-url" ["--unpack", "--type", "sha256", T.unpack $ gitUriToText uri]
164194 pure hash
165195
166−nixPrefetchGit :: MonadObelisk m => URI -> Text -> Bool -> m NixSha256
196+nixPrefetchGit :: MonadObelisk m => GitUri -> Text -> Bool -> m NixSha256
167197nixPrefetchGit uri rev fetchSubmodules =
168− withExitFailMessage ("nix-prefetch-git: Failed to determine sha256 hash of Git repo " <> render uri <> " at " <> rev) $ do
198+ withExitFailMessage ("nix-prefetch-git: Failed to determine sha256 hash of Git repo " <> gitUriToText uri <> " at " <> rev) $ do
169199 out <- readProcessAndLogStderr Debug $
170200 proc "nix-prefetch-git" $ filter (/="")
171− [ "--url", T.unpack $ render uri
201+ [ "--url", T.unpack $ gitUriToText uri
172202 , "--rev", T.unpack rev
173203 , if fetchSubmodules then "--fetch-submodules" else ""
174204 , "--quiet"
@@ -286,10 +316,12 @@ parseGitHubSource v = do
286316 owner <- v Aeson..: "owner"
287317 repo <- v Aeson..: "repo"
288318 branch <- v Aeson..:! "branch"
319+ private <- v Aeson..:? "private"
289320 pure $ GitHubSource
290321 { _gitHubSource_owner = owner
291322 , _gitHubSource_repo = repo
292323 , _gitHubSource_branch = branch
324+ , _gitHubSource_private = fromMaybe False private
293325 }
294326
295327parseGitSource :: Aeson.Object -> Aeson.Parser GitSource
@@ -297,10 +329,12 @@ parseGitSource v = do
297329 Just url <- parseGitUri <$> v Aeson..: "url"
298330 branch <- v Aeson..:! "branch"
299331 fetchSubmodules <- v Aeson..:! "fetchSubmodules"
332+ private <- v Aeson..:? "private"
300333 pure $ GitSource
301334 { _gitSource_url = url
302335 , _gitSource_branch = branch
303336 , _gitSource_fetchSubmodules = fromMaybe False fetchSubmodules
337+ , _gitSource_private = fromMaybe False private
304338 }
305339
306340overwriteThunk :: MonadObelisk m => FilePath -> ThunkPtr -> m ()
@@ -327,13 +361,15 @@ encodeThunkPtrData (ThunkPtr rev src) = case src of
327361 , ("branch" .=) <$> _gitHubSource_branch s
328362 , Just $ "rev" .= Ref.toHexString (_thunkRev_commit rev)
329363 , Just $ "sha256" .= _thunkRev_nixSha256 rev
364+ , Just $ "private" .= _gitHubSource_private s
330365 ]
331366 ThunkSource_Git s -> encodePretty' plainGitCfg $ Aeson.object $ catMaybes
332− [ Just $ "url" .= render (_gitSource_url s)
367+ [ Just $ "url" .= gitUriToText (_gitSource_url s)
333368 , Just $ "rev" .= Ref.toHexString (_thunkRev_commit rev)
334369 , ("branch" .=) <$> _gitSource_branch s
335370 , Just $ "sha256" .= _thunkRev_nixSha256 rev
336371 , Just $ "fetchSubmodules" .= _gitSource_fetchSubmodules s
372+ , Just $ "private" .= _gitSource_private s
337373 ]
338374 where
339375 githubCfg = defConfig
@@ -354,6 +390,7 @@ encodeThunkPtrData (ThunkPtr rev src) = case src of
354390 [ "url"
355391 , "rev"
356392 , "sha256"
393+ , "private"
357394 , "fetchSubmodules"
358395 ] <> compare
359396 , confTrailingNewline = True
@@ -377,8 +414,8 @@ createThunkWithLatest target s = do
377414 , _thunkPtr_rev = rev
378415 }
379416
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
417+updateThunkToLatest :: MonadObelisk m => ThunkUpdateConfig -> FilePath -> m ()
418+updateThunkToLatest (ThunkUpdateConfig mBranch thunkConfig) target = withSpinner' ("Updating thunk " <> T.pack target <> " to latest") (pure $ const $ "Thunk " <> T.pack target <> " updated to latest") $ do
382419 checkThunkDirectory "ob thunk update directory cannot be '.'" target
383420 -- check to see if thunk should be updated to a specific branch or just update it's current branch
384421 case mBranch of
@@ -390,7 +427,7 @@ updateThunkToLatest target mBranch = withSpinner' ("Updating thunk " <> T.pack t
390427 ThunkData_Checkout _ -> failWith "cannot update an unpacked thunk"
391428 let src = _thunkPtr_source ptr
392429 rev <- getLatestRev src
393− overwriteThunk overwrite $ ThunkPtr
430+ overwriteThunk overwrite $ modifyThunkPtrByConfig thunkConfig $ ThunkPtr
394431 { _thunkPtr_source = src
395432 , _thunkPtr_rev = rev
396433 }
@@ -398,24 +435,25 @@ updateThunkToLatest target mBranch = withSpinner' ("Updating thunk " <> T.pack t
398435 Left err -> failWith $ T.pack $ "thunk update: " <> show err
399436 Right c -> case c of
400437 ThunkData_Packed t -> case _thunkPtr_source t of
401− ThunkSource_Git tsg -> setThunk target tsg branch
438+ ThunkSource_Git tsg -> setThunk thunkConfig target tsg branch
402439 ThunkSource_GitHub tsgh -> do
403440 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."
441+ setThunk thunkConfig target tsg branch
442+ 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."
406443
407−setThunk :: MonadObelisk m => FilePath -> GitSource -> String -> m ()
408−setThunk target gs branch = do
444+setThunk :: MonadObelisk m => ThunkConfig -> FilePath -> GitSource -> String -> m ()
445+setThunk thunkConfig target gs branch = do
409446 newThunkPtr <- uriThunkPtr (_gitSource_url gs) (Just $ T.pack branch) Nothing
410447 overwriteThunk target newThunkPtr
411− updateThunkToLatest target Nothing
448+ updateThunkToLatest (ThunkUpdateConfig Nothing thunkConfig) target
412449
413450-- | All recognized github standalone loaders, ordered from newest to oldest.
414451-- This tool will only ever produce the newest one when it writes a thunk.
415452gitHubStandaloneLoaders :: NonEmpty Text
416453gitHubStandaloneLoaders =
417− gitHubStandaloneLoaderV2 :|
454+ gitHubStandaloneLoaderV4 :|
418455 [ gitHubStandaloneLoaderV3
456+ , gitHubStandaloneLoaderV2
419457 , gitHubStandaloneLoaderV1
420458 ]
421459
@@ -455,10 +493,23 @@ gitHubStandaloneLoaderV3 = T.unlines
455493 , "in import (fetch (builtins.fromJSON (builtins.readFile ./github.json)))"
456494 ]
457495
496+gitHubStandaloneLoaderV4 :: Text
497+gitHubStandaloneLoaderV4 = T.unlines
498+ [ "# DO NOT HAND-EDIT THIS FILE"
499+ , "let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }:"
500+ , " if !fetchSubmodules && !private then builtins.fetchTarball {"
501+ , " url = \"https://github.com/${owner}/${repo}/archive/${rev}.tar.gz\"; inherit sha256;"
502+ , " } else (import <nixpkgs> {}).fetchFromGitHub {"
503+ , " inherit owner repo rev sha256 fetchSubmodules private;"
504+ , " };"
505+ , "in import (fetch (builtins.fromJSON (builtins.readFile ./github.json)))"
506+ ]
507+
458508plainGitStandaloneLoaders :: NonEmpty Text
459509plainGitStandaloneLoaders =
460− plainGitStandaloneLoaderV1 :|
461− [ plainGitStandaloneLoaderV2
510+ plainGitStandaloneLoaderV3 :|
511+ [ plainGitStandaloneLoaderV1
512+ , plainGitStandaloneLoaderV2
462513 ]
463514
464515plainGitStandaloneLoaderV1 :: Text
@@ -479,6 +530,22 @@ plainGitStandaloneLoaderV2 = T.unlines
479530 , "in import (fetchGit (builtins.fromJSON (builtins.readFile ./git.json)))"
480531 ]
481532
533+plainGitStandaloneLoaderV3 :: Text
534+plainGitStandaloneLoaderV3 = T.unlines
535+ [ "# DO NOT HAND-EDIT THIS FILE"
536+ , "let fetch = {url, rev, ref ? null, sha256 ? null, fetchSubmodules ? false, private ? false, ...}:"
537+ , " let realUrl = let firstChar = builtins.substring 0 1 url; in"
538+ , " if firstChar == \"/\" then /. + url"
539+ , " else if firstChar == \".\" then ./. + url"
540+ , " else url;"
541+ , " in if !fetchSubmodules && private then builtins.fetchGit {"
542+ , " url = realUrl; inherit rev;"
543+ , " } else (import <nixpkgs> {}).fetchgit {"
544+ , " url = realUrl; inherit rev sha256;"
545+ , " };"
546+ , "in import (fetch (builtins.fromJSON (builtins.readFile ./git.json)))"
547+ ]
548+
482549thunkFileNames :: [FilePath]
483550thunkFileNames = ["default.nix", "github.json", "git.json"]
484551
@@ -520,7 +587,7 @@ nixBuildThunkAttrWithCache thunkDir attr = do
520587 Just c -> return c
521588 Nothing -> do
522589 putLog Warning $ T.pack $ mconcat [thunkDir, ": ", attr, " not cached, building ..."]
523− _ <- nixCmd $ NixCmd_Build$ def
590+ _ <- nixCmd $ NixCmd_Build $ def
524591 Lens.& nixBuildConfig_outLink Lens..~ OutLink_IndirectRoot cachePath
525592 Lens.& nixCmdConfig_target Lens..~ Target
526593 { _target_path = Just thunkDir
@@ -568,13 +635,13 @@ updateThunk p f = withSystemTempDirectory "obelisk-thunkptr-" $ \tmpDir -> do
568635 Right (ThunkData_Packed _) -> do
569636 let tmpThunk = tmpDir </> "thunk"
570637 callProcessAndLogOutput (Notice, Error) $
571− proc "cp" ["-r", "-T", thunkDir, tmpThunk]
638+ proc cp ["-r", "-T", thunkDir, tmpThunk]
572639 return tmpThunk
573− Right _ -> failWith $ "Thunk is not packed"
640+ Right _ -> failWith "Thunk is not packed"
574641 updateThunkFromTmp p' = do
575− _ <- packThunk' True False p'
642+ _ <- packThunk' True (ThunkPackConfig False (ThunkConfig Nothing)) p'
576643 callProcessAndLogOutput (Notice, Error) $
577− proc "cp" ["-r", "-T", p', p]
644+ proc cp ["-r", "-T", p', p]
578645
579646finalMsg :: Bool -> (a -> Text) -> Maybe (a -> Text)
580647finalMsg noTrail s = if noTrail then Nothing else Just s
@@ -606,7 +673,7 @@ unpackThunk' noTrail thunkDir = checkThunkDirectory "Can't pack/unpack from with
606673 let git = callProcessAndLogOutput (Notice, Notice) . gitProc tmpRepo
607674 git $ [ "clone" ]
608675 ++ ("--recursive" <$ guard (_gitSource_fetchSubmodules s))
609− ++ [ T.unpack $ render $ _gitSource_url s ]
676+ ++ [ T.unpack $ gitUriToText $ _gitSource_url s ]
610677 ++ do branch <- maybeToList $ _gitSource_branch s
611678 [ "--branch", T.unpack $ untagName branch ]
612679 git ["reset", "--hard", Ref.toHexString $ _thunkRev_commit $ _thunkPtr_rev tptr]
@@ -615,31 +682,39 @@ unpackThunk' noTrail thunkDir = checkThunkDirectory "Can't pack/unpack from with
615682
616683 liftIO $ createDirectory obGitDir
617684 callProcessAndLogOutput (Notice, Error) $
618− proc "cp" ["-r", "-T", thunkDir </> ".", obGitDir </> "orig-thunk"]
685+ proc cp ["-r", "-T", thunkDir </> ".", obGitDir </> "orig-thunk"]
619686 callProcessAndLogOutput (Notice, Error) $
620687 proc "rm" ["-r", thunkDir]
621688 callProcessAndLogOutput (Notice, Error) $
622689 proc "mv" ["-T", tmpRepo, thunkDir]
623690
624691--TODO: add a rollback mode to pack to the original thunk
625−packThunk :: MonadObelisk m => Bool -> FilePath -> m ThunkPtr
692+packThunk :: MonadObelisk m => ThunkPackConfig -> FilePath -> m ThunkPtr
626693packThunk = packThunk' False
627694
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
695+packThunk' :: MonadObelisk m => Bool -> ThunkPackConfig -> FilePath -> m ThunkPtr
696+packThunk' noTrail (ThunkPackConfig force thunkConfig) thunkDir = checkThunkDirectory "Can't pack/unpack from within the thunk directory" thunkDir >> readThunk thunkDir >>= \case
630697 Left err -> failWith $ T.pack $ "thunk pack: " <> show err
631698 Right (ThunkData_Packed _) -> failWith "pack: thunk is already packed"
632699 Right (ThunkData_Checkout _) -> do
633700 withSpinner' ("Packing thunk " <> T.pack thunkDir)
634701 (finalMsg noTrail $ const $ "Packed thunk " <> T.pack thunkDir) $ do
635− thunkPtr <- getThunkPtr (not force) thunkDir
702+ thunkPtr <- modifyThunkPtrByConfig thunkConfig <$> getThunkPtr (not force) thunkDir
636703 callProcessAndLogOutput (Debug, Error) $ proc "rm" ["-rf", thunkDir]
637704 liftIO $ createThunk thunkDir thunkPtr
638705 pure thunkPtr
639706
707+modifyThunkPtrByConfig :: ThunkConfig -> ThunkPtr -> ThunkPtr
708+modifyThunkPtrByConfig (ThunkConfig markPrivate') ptr = case markPrivate' of
709+ Nothing -> ptr
710+ Just markPrivate -> ptr { _thunkPtr_source = case _thunkPtr_source ptr of
711+ ThunkSource_Git s -> ThunkSource_Git $ s { _gitSource_private = markPrivate }
712+ ThunkSource_GitHub s -> ThunkSource_GitHub $ s { _gitHubSource_private = markPrivate }
713+ }
714+
640715getThunkPtr :: forall m. MonadObelisk m => Bool -> FilePath -> m ThunkPtr
641716getThunkPtr checkClean thunkDir = do
642− when checkClean $ ensureCleanGitRepo thunkDir True $
717+ when checkClean $ ensureCleanGitRepo thunkDir True
643718 "thunk pack: thunk checkout contains unsaved modifications"
644719
645720 -- Check whether there are any stashes
@@ -661,7 +736,7 @@ getThunkPtr checkClean thunkDir = do
661736 <$> T.lines
662737 <$> readGitProcess thunkDir ["rev-parse", "HEAD"]
663738 case b of
664− (Just "HEAD") -> failWith $ T.unlines $
739+ (Just "HEAD") -> failWith $ T.unlines
665740 [ "thunk pack: You are in 'detached HEAD' state."
666741 , "If you want to pack at the current ref \
667742 \then please create a new branch with 'git checkout -b <new-branch-name>' and push this upstream."
@@ -733,7 +808,7 @@ getThunkPtr checkClean thunkDir = do
733808 [ "thunk pack: Certain branches in the thunk have commits not yet pushed upstream:"
734809 , ""
735810 ] ++
736− (flip map (Map.toList nonGood) $ \(branch, (upstream, (ahead, behind))) -> mconcat
811+ flip map (Map.toList nonGood) (\(branch, (upstream, (ahead, behind))) -> mconcat
737812 [" ", branch, " ahead: ", T.pack (show ahead), " behind: ", T.pack (show behind), " remote branch ", upstream]) ++
738813 [ ""
739814 , "Please push these upstream and try again. (Or just fetch, if they are somehow \
@@ -741,7 +816,7 @@ getThunkPtr checkClean thunkDir = do
741816 ]
742817
743818 -- 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."
819+ putLog Informational "All changes safe in git remotes. OK to pack thunk."
745820
746821 let remote = maybe "origin" snd $ flip Map.lookup headUpstream =<< mCurrentBranch
747822
@@ -773,7 +848,7 @@ getLatestRev os = do
773848-- performance. If that doesn't work (e.g. authentication issue), we fall back
774849-- on just doing things the normal way for git repos in general, and save it as
775850-- a regular git thunk.
776−uriThunkPtr :: MonadObelisk m => URI -> Maybe Text -> Maybe Text -> m ThunkPtr
851+uriThunkPtr :: MonadObelisk m => GitUri -> Maybe Text -> Maybe Text -> m ThunkPtr
777852uriThunkPtr uri mbranch mcommit = do
778853 commit <- case mcommit of
779854 Nothing -> gitGetCommitBranch uri mbranch >>= return . snd
@@ -784,7 +859,7 @@ uriThunkPtr uri mbranch mcommit = do
784859 case rev of
785860 Right r -> pure (ThunkSource_GitHub s, r)
786861 Left e -> do
787− putLog Warning $ "\
862+ putLog Warning "\
788863\Failed to fetch archive from GitHub. This is probably a private repo. \
789864\Falling back on normal fetchgit. Original failure:"
790865 errorToWarning e
@@ -801,33 +876,33 @@ uriThunkPtr uri mbranch mcommit = do
801876-- If the thunk is a GitHub thunk and fails, we do *not* fall back like with
802877-- `uriThunkPtr`. Unlike a plain URL, a thunk src explicitly states which method
803878-- 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
879+uriToThunkSource :: GitUri -> Maybe Text -> ThunkSource
880+uriToThunkSource (GitUri u)
881+ | Right uriAuth <- URI.uriAuthority u
882+ , Just scheme <- URI.unRText <$> URI.uriScheme u
808883 , case scheme of
809− "ssh" -> uriAuth == Authority
810− { authUserInfo = Just $ UserInfo (fromRight' $ mkUsername "git") Nothing
811− , authHost = fromRight' $ mkHost "github.com"
812− , authPort = Nothing
884+ "ssh" -> uriAuth == URI.Authority
885+ { URI.authUserInfo = Just $ URI.UserInfo (fromRight' $ URI.mkUsername "git") Nothing
886+ , URI.authHost = fromRight' $ URI.mkHost "github.com"
887+ , URI.authPort = Nothing
813888 }
814889 s -> s `L.elem` [ "git", "https", "http" ] -- "http:" just redirects to "https:"
815− && unRText (authHost uriAuth) == "github.com"
816− , Just (_, owner :| [repoish]) <- uriPath u
890+ && URI.unRText (URI.authHost uriAuth) == "github.com"
891+ , Just (_, owner :| [repoish]) <- URI.uriPath u
817892 = \mbranch -> ThunkSource_GitHub $ GitHubSource
818− { _gitHubSource_owner = N $ unRText owner
893+ { _gitHubSource_owner = N $ URI.unRText owner
819894 , _gitHubSource_repo = N $ let
820− repoish' = unRText repoish
821− in case T.stripSuffix ".git" repoish' of
822− Just repo -> repo
823− Nothing -> repoish'
895+ repoish' = URI.unRText repoish
896+ in fromMaybe repoish' $ T.stripSuffix ".git" repoish'
824897 , _gitHubSource_branch = N <$> mbranch
898+ , _gitHubSource_private = False -- TODO: Can we try something to infer this?
825899 }
826900
827901 | otherwise = \mbranch -> ThunkSource_Git $ GitSource
828− { _gitSource_url = u
902+ { _gitSource_url = GitUri u
829903 , _gitSource_branch = N <$> mbranch
830904 , _gitSource_fetchSubmodules = False -- TODO: How do we determine if this should be true?
905+ , _gitSource_private = False -- TODO: Can we try something to infer this?
831906 }
832907
833908-- Funny signature indicates no effects depend on the optional branch name.
@@ -840,19 +915,19 @@ githubThunkRev
840915githubThunkRev s commit = do
841916 owner <- forcePP $ _gitHubSource_owner s
842917 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
918+ revTarball <- URI.mkPathPiece $ commit <> ".tar.gz"
919+ let archiveUri = GitUri $ URI.URI
920+ { URI.uriScheme = Just $ fromRight' $ URI.mkScheme "https"
921+ , URI.uriAuthority = Right $ URI.Authority
922+ { URI.authUserInfo = Nothing
923+ , URI.authHost = fromRight' $ URI.mkHost "github.com"
924+ , URI.authPort = Nothing
850925 }
851− , uriPath = Just ( False
852− , owner :| [ repo, fromRight' $ mkPathPiece "archive", revTarball ]
926+ , URI.uriPath = Just ( False
927+ , owner :| [ repo, fromRight' $ URI.mkPathPiece "archive", revTarball ]
853928 )
854− , uriQuery = []
855− , uriFragment = Nothing
929+ , URI.uriQuery = []
930+ , URI.uriFragment = Nothing
856931 }
857932 hash <- getNixSha256ForUriUnpacked archiveUri
858933 putLog Debug $ "Nix sha256 is " <> hash
@@ -861,8 +936,8 @@ githubThunkRev s commit = do
861936 , _thunkRev_nixSha256 = hash
862937 }
863938 where
864− forcePP :: Name entity -> m (RText 'PathPiece)
865− forcePP = mkPathPiece . untagName
939+ forcePP :: Name entity -> m (URI.RText 'URI.PathPiece)
940+ forcePP = URI.mkPathPiece . untagName
866941
867942gitThunkRev
868943 :: MonadObelisk m
@@ -871,11 +946,11 @@ gitThunkRev
871946 -> m ThunkRev
872947gitThunkRev s commit = do
873948 let u = _gitSource_url s
874− protocols = ["https", "ssh", "git"]
875− Just scheme <- pure $ unRText <$> uriScheme u
949+ protocols = ["file", "https", "ssh", "git"]
950+ scheme = maybe "file" URI.unRText $ URI.uriScheme $ (\(GitUri x) -> x) u
876951 unless (T.toLower scheme `elem` protocols) $
877952 failWith $ "obelisk currently only supports "
878− <> T.intercalate ", " protocols <> " protocols for non-GitHub remotes"
953+ <> T.intercalate ", " protocols <> " protocols for plain Git remotes"
879954 hash <- nixPrefetchGit u commit $ _gitSource_fetchSubmodules s
880955 putLog Informational $ "Nix sha256 is " <> hash
881956 pure $ ThunkRev
@@ -889,10 +964,10 @@ gitThunkRev s commit = do
889964-- If the branch name is passed in, it is returned exactly as-is. If it is not
890965-- passed it, the default branch of the repo is used instead.
891966gitGetCommitBranch
892− :: MonadObelisk m => URI -> Maybe Text -> m (Text, CommitId)
967+ :: MonadObelisk m => GitUri -> Maybe Text -> m (Text, CommitId)
893968gitGetCommitBranch uri mbranch = withExitFailMessage ("Failure for git remote " <> uriMsg) $ do
894969 (_, bothMaps) <- gitLsRemote
895− (T.unpack $ render uri)
970+ (T.unpack $ gitUriToText uri)
896971 (GitRef_Branch <$> mbranch)
897972 Nothing
898973 branch <- case mbranch of
@@ -908,18 +983,21 @@ gitGetCommitBranch uri mbranch = withExitFailMessage ("Failure for git remote "
908983 pure (branch, commit)
909984 where
910985 rethrowE = either failWith pure
911− uriMsg = render uri
986+ uriMsg = gitUriToText uri
987+
988+parseGitUri :: Text -> Maybe GitUri
989+parseGitUri x = GitUri <$> (parseFileURI x <|> parseAbsoluteURI x <|> parseSshShorthand x)
912990
913−parseGitUri :: Text -> Maybe URI
914−parseGitUri x = parseAbsoluteURI x <|> parseSshShorthand x
991+parseFileURI :: Text -> Maybe URI.URI
992+parseFileURI uri = if "/" `T.isPrefixOf` uri then parseAbsoluteURI ("file://" <> uri) else Nothing
915993
916−parseAbsoluteURI :: Text -> Maybe URI
994+parseAbsoluteURI :: Text -> Maybe URI.URI
917995parseAbsoluteURI uri = do
918− parsedUri <- mkURI uri
919− guard $ isPathAbsolute parsedUri
920− pure $ parsedUri
996+ parsedUri <- URI.mkURI uri
997+ guard $ URI.isPathAbsolute parsedUri
998+ pure parsedUri
921999
922−parseSshShorthand :: Text -> Maybe URI
1000+parseSshShorthand :: Text -> Maybe URI.URI
9231001parseSshShorthand uri = do
9241002 -- This is what git does to check that the remote
9251003 -- is not a local file path when parsing shorthand.
@@ -932,4 +1010,4 @@ parseSshShorthand uri = do
9321010 -- This check is used to disambiguate a filepath containing a colon from shorthand
9331011 guard $ isNothing (T.findIndex (=='/') authAndHostname)
9341012 && not (T.null colonAndPath)
935− mkURI properUri
1013+ URI.mkURI properUri