@@ -9,6 +9,7 @@
99{-# LANGUAGE TypeApplications #-}
1010module Obelisk.Command.Thunk
1111 ( GitHubSource (..)
12+ , GitUri (..)
1213 , ReadThunkError (..)
1314 , ThunkConfig (..)
1415 , ThunkData (..)
@@ -17,19 +18,20 @@ module Obelisk.Command.Thunk
1718 , ThunkRev (..)
1819 , ThunkSource (..)
1920 , ThunkUpdateConfig (..)
20− , getThunkGitBranch
21− , getLatestRev
22− , updateThunkToLatest
2321 , createThunk
2422 , createThunkWithLatest
23+ , getLatestRev
24+ , getThunkGitBranch
25+ , getThunkPtr
26+ , gitUriToText
2527 , nixBuildAttrWithCache
2628 , nixBuildThunkAttrWithCache
27− , unpackThunk
2829 , packThunk
30+ , parseGitUri
2931 , readThunk
32+ , unpackThunk
3033 , updateThunk
31− , getThunkPtr
32− , parseGitUri
34+ , updateThunkToLatest
3335 , uriThunkPtr
3436 ) where
3537
@@ -71,7 +73,7 @@ import System.FilePath
7173import System.IO.Error
7274import System.IO.Temp
7375import System.Posix (getSymbolicLinkStatus, modificationTime)
74−import Text.URI
76+import qualified Text.URI as URI
7577
7678import Obelisk.App (MonadObelisk)
7779import Obelisk.CliApp
@@ -117,8 +119,17 @@ data GitHubSource = GitHubSource
117119 }
118120 deriving (Show, Eq, Ord)
119121
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+
120131data GitSource = GitSource
121− { _gitSource_url :: URI
132+ { _gitSource_url :: GitUri
122133 , _gitSource_branch :: Maybe (Name Branch)
123134 , _gitSource_fetchSubmodules :: Bool
124135 , _gitSource_private :: Bool
@@ -142,21 +153,21 @@ data ThunkPackConfig = ThunkPackConfig
142153-- | Convert a GitHub source to a regular Git source. Assumes no submodules.
143154forgetGithub :: Bool -> GitHubSource -> GitSource
144155forgetGithub useSsh s = GitSource
145− { _gitSource_url = URI
146− { uriScheme = Just $ fromRight' $ mkScheme $ if useSsh then "ssh" else "https"
147− , uriAuthority = Right $ Authority
148− { 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
149160 <$ guard useSsh
150− , authHost = fromRight' $ mkHost "github.com"
151− , authPort = Nothing
161+ , URI.authHost = fromRight' $ URI.mkHost "github.com"
162+ , URI.authPort = Nothing
152163 }
153− , uriPath = Just ( False
154− , fromRight' . mkPathPiece <$>
164+ , URI.uriPath = Just ( False
165+ , fromRight' . URI.mkPathPiece <$>
155166 untagName (_gitHubSource_owner s)
156167 :| [ untagName (_gitHubSource_repo s) <> ".git" ]
157168 )
158− , uriQuery = []
159− , uriFragment = Nothing
169+ , URI.uriQuery = []
170+ , URI.uriFragment = Nothing
160171 }
161172 , _gitSource_branch = _gitHubSource_branch s
162173 , _gitSource_fetchSubmodules = False
@@ -174,20 +185,20 @@ commitNameToRef (N c) = Ref.fromHex $ encodeUtf8 c
174185-- TODO: Use spinner here.
175186getNixSha256ForUriUnpacked
176187 :: MonadObelisk m
177− => URI
188+ => GitUri
178189 -> m NixSha256
179190getNixSha256ForUriUnpacked uri =
180− 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
181192 [hash] <- fmap T.lines $ readProcessAndLogOutput (Debug, Debug) $
182− proc "nix-prefetch-url" ["--unpack" , "--type" , "sha256" , T.unpack $ render uri]
193+ proc "nix-prefetch-url" ["--unpack", "--type", "sha256", T.unpack $ gitUriToText uri]
183194 pure hash
184195
185−nixPrefetchGit :: MonadObelisk m => URI -> Text -> Bool -> m NixSha256
196+nixPrefetchGit :: MonadObelisk m => GitUri -> Text -> Bool -> m NixSha256
186197nixPrefetchGit uri rev fetchSubmodules =
187− 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
188199 out <- readProcessAndLogStderr Debug $
189200 proc "nix-prefetch-git" $ filter (/="")
190− [ "--url", T.unpack $ render uri
201+ [ "--url", T.unpack $ gitUriToText uri
191202 , "--rev", T.unpack rev
192203 , if fetchSubmodules then "--fetch-submodules" else ""
193204 , "--quiet"
@@ -353,7 +364,7 @@ encodeThunkPtrData (ThunkPtr rev src) = case src of
353364 , Just $ "private" .= _gitHubSource_private s
354365 ]
355366 ThunkSource_Git s -> encodePretty' plainGitCfg $ Aeson.object $ catMaybes
356− [ Just $ "url" .= render (_gitSource_url s)
367+ [ Just $ "url" .= gitUriToText (_gitSource_url s)
357368 , Just $ "rev" .= Ref.toHexString (_thunkRev_commit rev)
358369 , ("branch" .=) <$> _gitSource_branch s
359370 , Just $ "sha256" .= _thunkRev_nixSha256 rev
@@ -662,7 +673,7 @@ unpackThunk' noTrail thunkDir = checkThunkDirectory "Can't pack/unpack from with
662673 let git = callProcessAndLogOutput (Notice, Notice) . gitProc tmpRepo
663674 git $ [ "clone" ]
664675 ++ ("--recursive" <$ guard (_gitSource_fetchSubmodules s))
665− ++ [ T.unpack $ render $ _gitSource_url s ]
676+ ++ [ T.unpack $ gitUriToText $ _gitSource_url s ]
666677 ++ do branch <- maybeToList $ _gitSource_branch s
667678 [ "--branch", T.unpack $ untagName branch ]
668679 git ["reset", "--hard", Ref.toHexString $ _thunkRev_commit $ _thunkPtr_rev tptr]
@@ -837,7 +848,7 @@ getLatestRev os = do
837848-- performance. If that doesn't work (e.g. authentication issue), we fall back
838849-- on just doing things the normal way for git repos in general, and save it as
839850-- a regular git thunk.
840−uriThunkPtr :: MonadObelisk m => URI -> Maybe Text -> Maybe Text -> m ThunkPtr
851+uriThunkPtr :: MonadObelisk m => GitUri -> Maybe Text -> Maybe Text -> m ThunkPtr
841852uriThunkPtr uri mbranch mcommit = do
842853 commit <- case mcommit of
843854 Nothing -> gitGetCommitBranch uri mbranch >>= return . snd
@@ -865,30 +876,30 @@ uriThunkPtr uri mbranch mcommit = do
865876-- If the thunk is a GitHub thunk and fails, we do *not* fall back like with
866877-- `uriThunkPtr`. Unlike a plain URL, a thunk src explicitly states which method
867878-- should be employed, and so we respect that.
868−uriToThunkSource :: URI -> Maybe Text -> ThunkSource
869−uriToThunkSource u
870− | Right uriAuth <- uriAuthority u
871− , 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
872883 , case scheme of
873− "ssh" -> uriAuth == Authority
874− { authUserInfo = Just $ UserInfo (fromRight' $ mkUsername "git") Nothing
875− , authHost = fromRight' $ mkHost "github.com"
876− , 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
877888 }
878889 s -> s `L.elem` [ "git", "https", "http" ] -- "http:" just redirects to "https:"
879− && unRText (authHost uriAuth) == "github.com"
880− , Just (_, owner :| [repoish]) <- uriPath u
890+ && URI.unRText (URI.authHost uriAuth) == "github.com"
891+ , Just (_, owner :| [repoish]) <- URI.uriPath u
881892 = \mbranch -> ThunkSource_GitHub $ GitHubSource
882− { _gitHubSource_owner = N $ unRText owner
893+ { _gitHubSource_owner = N $ URI.unRText owner
883894 , _gitHubSource_repo = N $ let
884− repoish' = unRText repoish
895+ repoish' = URI.unRText repoish
885896 in fromMaybe repoish' $ T.stripSuffix ".git" repoish'
886897 , _gitHubSource_branch = N <$> mbranch
887898 , _gitHubSource_private = False -- TODO: Can we try something to infer this?
888899 }
889900
890901 | otherwise = \mbranch -> ThunkSource_Git $ GitSource
891− { _gitSource_url = u
902+ { _gitSource_url = GitUri u
892903 , _gitSource_branch = N <$> mbranch
893904 , _gitSource_fetchSubmodules = False -- TODO: How do we determine if this should be true?
894905 , _gitSource_private = False -- TODO: Can we try something to infer this?
@@ -904,19 +915,19 @@ githubThunkRev
904915githubThunkRev s commit = do
905916 owner <- forcePP $ _gitHubSource_owner s
906917 repo <- forcePP $ _gitHubSource_repo s
907− revTarball <- mkPathPiece $ commit <> ".tar.gz"
908− let archiveUri = URI
909− { uriScheme = Just $ fromRight' $ mkScheme "https"
910− , uriAuthority = Right $ Authority
911− { authUserInfo = Nothing
912− , authHost = fromRight' $ mkHost "github.com"
913− , 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
914925 }
915− , uriPath = Just ( False
916− , owner :| [ repo, fromRight' $ mkPathPiece "archive", revTarball ]
926+ , URI.uriPath = Just ( False
927+ , owner :| [ repo, fromRight' $ URI.mkPathPiece "archive", revTarball ]
917928 )
918− , uriQuery = []
919− , uriFragment = Nothing
929+ , URI.uriQuery = []
930+ , URI.uriFragment = Nothing
920931 }
921932 hash <- getNixSha256ForUriUnpacked archiveUri
922933 putLog Debug $ "Nix sha256 is " <> hash
@@ -925,8 +936,8 @@ githubThunkRev s commit = do
925936 , _thunkRev_nixSha256 = hash
926937 }
927938 where
928− forcePP :: Name entity -> m (RText 'PathPiece)
929− forcePP = mkPathPiece . untagName
939+ forcePP :: Name entity -> m (URI.RText 'URI.PathPiece)
940+ forcePP = URI.mkPathPiece . untagName
930941
931942gitThunkRev
932943 :: MonadObelisk m
@@ -935,11 +946,11 @@ gitThunkRev
935946 -> m ThunkRev
936947gitThunkRev s commit = do
937948 let u = _gitSource_url s
938− protocols = ["https", "ssh", "git"]
939− Just scheme <- pure $ unRText <$> uriScheme u
949+ protocols = ["file", "https", "ssh", "git"]
950+ scheme = maybe "file" URI.unRText $ URI.uriScheme $ (\(GitUri x) -> x) u
940951 unless (T.toLower scheme `elem` protocols) $
941952 failWith $ "obelisk currently only supports "
942− <> T.intercalate ", " protocols <> " protocols for non-GitHub remotes"
953+ <> T.intercalate ", " protocols <> " protocols for plain Git remotes"
943954 hash <- nixPrefetchGit u commit $ _gitSource_fetchSubmodules s
944955 putLog Informational $ "Nix sha256 is " <> hash
945956 pure $ ThunkRev
@@ -953,10 +964,10 @@ gitThunkRev s commit = do
953964-- If the branch name is passed in, it is returned exactly as-is. If it is not
954965-- passed it, the default branch of the repo is used instead.
955966gitGetCommitBranch
956− :: MonadObelisk m => URI -> Maybe Text -> m (Text, CommitId)
967+ :: MonadObelisk m => GitUri -> Maybe Text -> m (Text, CommitId)
957968gitGetCommitBranch uri mbranch = withExitFailMessage ("Failure for git remote " <> uriMsg) $ do
958969 (_, bothMaps) <- gitLsRemote
959− (T.unpack $ render uri)
970+ (T.unpack $ gitUriToText uri)
960971 (GitRef_Branch <$> mbranch)
961972 Nothing
962973 branch <- case mbranch of
@@ -972,18 +983,21 @@ gitGetCommitBranch uri mbranch = withExitFailMessage ("Failure for git remote "
972983 pure (branch, commit)
973984 where
974985 rethrowE = either failWith pure
975− uriMsg = render uri
986+ uriMsg = gitUriToText uri
987+
988+parseGitUri :: Text -> Maybe GitUri
989+parseGitUri x = GitUri <$> (parseFileURI x <|> parseAbsoluteURI x <|> parseSshShorthand x)
976990
977−parseGitUri :: Text -> Maybe URI
978−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
979993
980−parseAbsoluteURI :: Text -> Maybe URI
994+parseAbsoluteURI :: Text -> Maybe URI.URI
981995parseAbsoluteURI uri = do
982− parsedUri <- mkURI uri
983− guard $ isPathAbsolute parsedUri
996+ parsedUri <- URI.mkURI uri
997+ guard $ URI.isPathAbsolute parsedUri
984998 pure parsedUri
985999
986−parseSshShorthand :: Text -> Maybe URI
1000+parseSshShorthand :: Text -> Maybe URI.URI
9871001parseSshShorthand uri = do
9881002 -- This is what git does to check that the remote
9891003 -- is not a local file path when parsing shorthand.
@@ -996,4 +1010,4 @@ parseSshShorthand uri = do
9961010 -- This check is used to disambiguate a filepath containing a colon from shorthand
9971011 guard $ isNothing (T.findIndex (=='/') authAndHostname)
9981012 && not (T.null colonAndPath)
999− mkURI properUri
1013+ URI.mkURI properUri