From e7134ca1ebf084aaa9a07831c5710a8bde0da790 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Mon, 18 Jan 2021 15:07:23 -0400
Subject: [PATCH] avoid partial functions in Git.Url

After the last commit, it was able to throw errors just due to an
unparseable url. This avoids needing to worry about that, as long
as the call site has already checked that it has a parseable url.
---
 Git/Construct.hs |  8 ++++----
 Git/Url.hs       | 25 +++++++------------------
 Remote/GitLFS.hs |  8 +++++---
 3 files changed, 16 insertions(+), 25 deletions(-)

diff --git a/Git/Construct.hs b/Git/Construct.hs
index 06b1a1176e..de896bbe59 100644
--- a/Git/Construct.hs
+++ b/Git/Construct.hs
@@ -121,16 +121,16 @@ localToUrl :: Repo -> Repo -> Repo
 localToUrl reference r
 	| not $ repoIsUrl reference = error "internal error; reference repo not url"
 	| repoIsUrl r = r
-	| otherwise = case Url.authority reference of
-		Nothing -> r
-		Just auth -> 
+	| otherwise = case (Url.authority reference, Url.scheme reference) of
+		(Just auth, Just s) -> 
 			let absurl = concat
-				[ Url.scheme reference
+				[ s
 				, "//"
 				, auth
 				, fromRawFilePath (repoPath r)
 				]
 			in r { location = Url $ fromJust $ parseURI absurl }
+		_ -> r
 
 {- Calculates a list of a repo's configured remotes, by parsing its config. -}
 fromRemotes :: Repo -> IO [Repo]
diff --git a/Git/Url.hs b/Git/Url.hs
index 367a6139f1..ad0e61b648 100644
--- a/Git/Url.hs
+++ b/Git/Url.hs
@@ -18,13 +18,11 @@ import Network.URI hiding (scheme, authority, path)
 
 import Common
 import Git.Types
-import Git
 
 {- Scheme of an URL repo. -}
-scheme :: Repo -> String
-scheme Repo { location = Url u } = uriScheme u
-scheme Repo { location = UnparseableUrl u } = unparseableUrl u
-scheme repo = notUrl repo
+scheme :: Repo -> Maybe String
+scheme Repo { location = Url u } = Just (uriScheme u)
+scheme _ = Nothing
 
 {- Work around a bug in the real uriRegName
  - <http://trac.haskell.org/network/ticket/40> -}
@@ -66,18 +64,9 @@ authority = authpart assemble
 {- Applies a function to extract part of the uriAuthority of an URL repo. -}
 authpart :: (URIAuth -> a) -> Repo -> Maybe a
 authpart a Repo { location = Url u } = a <$> uriAuthority u
-authpart _ Repo { location = UnparseableUrl u } = unparseableUrl u
-authpart _ repo = notUrl repo
+authpart _ _ = Nothing
 
 {- Path part of an URL repo. -}
-path :: Repo -> FilePath
-path Repo { location = Url u } = uriPath u
-path Repo { location = UnparseableUrl u } = unparseableUrl u
-path repo = notUrl repo
-
-notUrl :: Repo -> a
-notUrl repo = error $
-	"acting on local git repo " ++ repoDescribe repo ++ " not supported"
-
-unparseableUrl :: String -> a
-unparseableUrl u = error $ "unable to parse repo url " ++ u
+path :: Repo -> Maybe FilePath
+path Repo { location = Url u } = Just (uriPath u)
+path _ = Nothing
diff --git a/Remote/GitLFS.hs b/Remote/GitLFS.hs
index 9103105a7f..31c35456f3 100644
--- a/Remote/GitLFS.hs
+++ b/Remote/GitLFS.hs
@@ -255,14 +255,16 @@ discoverLFSEndpoint tro h
 			return Nothing
 		Just (Right hostuser) -> do
 			let port = Git.Url.port r
+			let p = fromMaybe (error "unknown path")
+				(Git.Url.path r)
 			-- Remove leading /~/ from path. That is added when
 			-- converting a scp-style repository location with
 			-- a relative path into an url, and is legal
 			-- according to git-clone(1), but github does not
 			-- support it.
-			let remotepath = if "/~/" `isPrefixOf` Git.Url.path r
-				then drop 3 (Git.Url.path r)
-				else Git.Url.path r
+			let remotepath = if "/~/" `isPrefixOf` p
+				then drop 3 p
+				else p
 			let ps = LFS.sshDiscoverEndpointCommand remotepath tro
 			-- Note that no shellEscape is done here, because
 			-- at least github's git-lfs implementation does