From 841e9fc078f114a7d1942d433a7f50af8f8552d4 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Fri, 9 Oct 2015 17:21:02 -0400
Subject: improve display when lockcontent fails

/dev/null stderr; ssh is still able to display a password prompt
despite this

Show some messages so the user knows it's locking a remote, and
knows if that locking failed.
---
 Remote/Git.hs             | 26 ++++++++++++++++----------
 Remote/Helper/Messages.hs | 27 +++++++++++++++------------
 2 files changed, 31 insertions(+), 22 deletions(-)

(limited to 'Remote')

diff --git a/Remote/Git.hs b/Remote/Git.hs
index c2bd307ad..80c0579cc 100644
--- a/Remote/Git.hs
+++ b/Remote/Git.hs
@@ -364,7 +364,7 @@ dropKey r key
 lockKey :: Remote -> Key -> (VerifiedCopy -> Annex r) -> Annex r
 lockKey r key callback
 	| not $ Git.repoIsUrl (repo r) =
-		guardUsable (repo r) cantlock $ do
+		guardUsable (repo r) failedlock $ do
 			inorigrepo <- Annex.makeRunner
 			-- Lock content from perspective of remote,
 			-- and then run the callback in the original
@@ -372,13 +372,17 @@ lockKey r key callback
 			onLocal r $ Annex.Content.lockContentShared key $ 
 				liftIO . inorigrepo . callback
 	| Git.repoIsSsh (repo r) = do
+		showLocking r
 		Just (cmd, params) <- Ssh.git_annex_shell (repo r) "lockcontent"
 			[Param $ key2file key] []
-		(Just hin, Just hout, Nothing, p) <- liftIO $ createProcess $
-			 (proc cmd (toCommand params))
-				{ std_in = CreatePipe
-				, std_out = CreatePipe
-				}
+		(Just hin, Just hout, Nothing, p) <- liftIO $ 
+			withFile devNull WriteMode $ \nullh ->
+				createProcess $
+					 (proc cmd (toCommand params))
+						{ std_in = CreatePipe
+						, std_out = CreatePipe
+						, std_err = UseHandle nullh
+						}
 		-- Wait for either the process to exit, or for it to
 		-- indicate the content is locked.
 		v <- liftIO $ race 
@@ -393,21 +397,23 @@ lockKey r key callback
 		let checkexited = not . isJust <$> getProcessExitCode p
 		case v of
 			Left _exited -> do
+				showNote "lockcontent failed"
 				liftIO $ do
 					hClose hin
 					hClose hout
-				cantlock
+				failedlock
 			Right l 
 				| l == Ssh.contentLockedMarker -> bracket_
 					noop
 					signaldone 
 					(withVerifiedCopy LockedCopy r checkexited callback)
 				| otherwise -> do
+					showNote "lockcontent failed"
 					signaldone
-					cantlock
-	| otherwise = cantlock
+					failedlock
+	| otherwise = failedlock
   where
-	cantlock = error "can't lock content"
+	failedlock = error "can't lock content"
 
 {- Tries to copy a key's content from a remote's annex to a file. -}
 copyFromRemote :: Remote -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex (Bool, Verification)
diff --git a/Remote/Helper/Messages.hs b/Remote/Helper/Messages.hs
index 377f2d231..6e72758fb 100644
--- a/Remote/Helper/Messages.hs
+++ b/Remote/Helper/Messages.hs
@@ -13,20 +13,23 @@ import Common.Annex
 import qualified Git
 import qualified Types.Remote as Remote
 
-class Checkable a where
-	descCheckable :: a -> String
+class Describable a where
+	describe :: a -> String
 
-instance Checkable Git.Repo where
-	descCheckable = Git.repoDescribe
+instance Describable Git.Repo where
+	describe = Git.repoDescribe
 
-instance Checkable (Remote.RemoteA a) where
-	descCheckable = Remote.name
+instance Describable (Remote.RemoteA a) where
+	describe = Remote.name
 
-instance Checkable String where
-	descCheckable = id
+instance Describable String where
+	describe = id
 
-showChecking :: Checkable a => a -> Annex ()
-showChecking v = showAction $ "checking " ++ descCheckable v
+showChecking :: Describable a => a -> Annex ()
+showChecking v = showAction $ "checking " ++ describe v
 
-cantCheck :: Checkable a => a -> e
-cantCheck v = error $ "unable to check " ++ descCheckable v
+cantCheck :: Describable a => a -> e
+cantCheck v = error $ "unable to check " ++ describe v
+
+showLocking :: Describable a => a -> Annex ()
+showLocking v = showAction $ "locking " ++ describe v
-- 
cgit v1.2.3