From efcba8f9fc8b9322f3c652f4d84ca4f345d45116 Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Sun, 29 Dec 2013 13:39:25 -0400
Subject: implement PREPARE-FAILURE for Tobias

---
 Remote/External.hs                               | 42 +++++++++++++++++-------
 Remote/External/Types.hs                         |  7 +++-
 doc/design/external_special_remote_protocol.mdwn |  2 ++
 doc/special_remotes/external/example.sh          |  8 +++--
 4 files changed, 45 insertions(+), 14 deletions(-)

diff --git a/Remote/External.hs b/Remote/External.hs
index b90d3f3fc..e444a729d 100644
--- a/Remote/External.hs
+++ b/Remote/External.hs
@@ -181,7 +181,8 @@ safely a = go =<< tryAnnex a
  -
  - Only one request can be made at a time, so locking is used.
  -
- - May throw exceptions, for example on protocol errors.
+ - May throw exceptions, for example on protocol errors, or
+ - when the repository cannot be used.
  -}
 handleRequest :: External -> Request -> Maybe MeterUpdate -> (Response -> Maybe (Annex a)) -> Annex a
 handleRequest external req mp responsehandler = 
@@ -189,12 +190,15 @@ handleRequest external req mp responsehandler =
 		handleRequest' lck external req mp responsehandler
 
 handleRequest' :: ExternalLock -> External -> Request -> Maybe MeterUpdate -> (Response -> Maybe (Annex a)) -> Annex a
-handleRequest' lck external req mp responsehandler = do
-	when (needsPREPARE req) $
+handleRequest' lck external req mp responsehandler
+	| needsPREPARE req = do
 		checkPrepared lck external
-	sendMessage lck external req
-	loop
+		go
+	| otherwise = go
   where
+  	go = do
+		sendMessage lck external req
+		loop
 	loop = receiveMessage lck external responsehandler
 		(\rreq -> Just $ handleRemoteRequest rreq >> loop)
 		(\msg -> Just $ handleAsyncMessage msg >> loop)
@@ -322,7 +326,7 @@ startExternal externaltype = liftIO $ do
 		{ externalSend = hin
 		, externalReceive = hout
 		, externalPid = pid
-		, externalPrepared = False
+		, externalPrepared = Unprepared
 		}
   where
 	cmd = externalRemoteProgram externaltype
@@ -354,14 +358,30 @@ checkVersion lck external (VERSION v) = Just $
 		else sendMessage lck external (ERROR "unsupported VERSION")
 checkVersion _ _ _ = Nothing
 
+{- If repo has not been prepared, sends PREPARE.
+ -
+ - If the repo fails to prepare, or failed before, throws an exception with
+ - the error message. -}
 checkPrepared :: ExternalLock -> External -> Annex ()
 checkPrepared lck external = 
 	fromExternal lck external externalPrepared $ \prepared ->
-		unless prepared $
-			handleRequest' lck external PREPARE Nothing $ \resp ->
-				case resp of
-					PREPARE_SUCCESS -> Just noop
-					_ -> Nothing
+		case prepared of
+			Prepared -> noop
+			FailedPrepare errmsg -> error errmsg
+			Unprepared -> 
+				handleRequest' lck external PREPARE Nothing $ \resp ->
+					case resp of
+						PREPARE_SUCCESS -> Just $
+							setprepared Prepared
+						PREPARE_FAILURE errmsg -> Just $ do
+							setprepared $ FailedPrepare errmsg
+							error errmsg
+						_ -> Nothing
+  where
+	setprepared status = liftIO . atomically $ do
+		let v = externalState external
+		st <- takeTMVar v
+		void $ putTMVar v $ st { externalPrepared = status }
 
 {- Caches the cost in the git config to avoid needing to start up an
  - external special remote every time time just to ask it what its
diff --git a/Remote/External/Types.hs b/Remote/External/Types.hs
index fbd050fe1..0525cdfee 100644
--- a/Remote/External/Types.hs
+++ b/Remote/External/Types.hs
@@ -14,6 +14,7 @@ module Remote.External.Types (
 	ExternalLock,
 	withExternalLock,
 	ExternalState(..),
+	PrepareStatus(..),
 	parseMessage,
 	Sendable(..),
 	Receivable(..),
@@ -67,9 +68,11 @@ data ExternalState = ExternalState
 	{ externalSend :: Handle
 	, externalReceive :: Handle
 	, externalPid :: ProcessHandle
-	, externalPrepared :: Bool
+	, externalPrepared :: PrepareStatus
 	}
 
+data PrepareStatus = Unprepared | Prepared | FailedPrepare ErrorMsg
+
 -- Constructor is not exported, and only created by newExternal.
 data ExternalLock = ExternalLock
 
@@ -124,6 +127,7 @@ instance Sendable Request where
 -- Responses the external remote can make to requests.
 data Response
 	= PREPARE_SUCCESS
+	| PREPARE_FAILURE ErrorMsg
 	| TRANSFER_SUCCESS Direction Key
 	| TRANSFER_FAILURE Direction Key ErrorMsg
 	| CHECKPRESENT_SUCCESS Key
@@ -139,6 +143,7 @@ data Response
 
 instance Receivable Response where
 	parseCommand "PREPARE-SUCCESS" = parse0 PREPARE_SUCCESS
+	parseCommand "PREPARE-FAILURE" = parse1 PREPARE_FAILURE
 	parseCommand "TRANSFER-SUCCESS" = parse2 TRANSFER_SUCCESS
 	parseCommand "TRANSFER-FAILURE" = parse3 TRANSFER_FAILURE
 	parseCommand "CHECKPRESENT-SUCCESS" = parse1 CHECKPRESENT_SUCCESS
diff --git a/doc/design/external_special_remote_protocol.mdwn b/doc/design/external_special_remote_protocol.mdwn
index 6e3c468f4..b92110729 100644
--- a/doc/design/external_special_remote_protocol.mdwn
+++ b/doc/design/external_special_remote_protocol.mdwn
@@ -130,6 +130,8 @@ while it's handling a request.
 
 * `PREPARE-SUCCESS`  
   Sent as a response to PREPARE once the special remote is ready for use.
+* `PREPARE-FAILURE ErrorMsg`
+  Sent as a response to PREPARE if the special remote cannot be used.
 * `TRANSFER-SUCCESS STORE|RETRIEVE Key`  
   Indicates the transfer completed successfully.
 * `TRANSFER-FAILURE STORE|RETRIEVE Key ErrorMsg`  
diff --git a/doc/special_remotes/external/example.sh b/doc/special_remotes/external/example.sh
index 428e2ecb9..5152ccc28 100755
--- a/doc/special_remotes/external/example.sh
+++ b/doc/special_remotes/external/example.sh
@@ -112,10 +112,14 @@ while read line; do
 			# Use GETCONFIG to get configuration settings,
 			# and do anything needed to get ready for using the
 			# special remote here.
+			getcreds
 			getconfig directory
 			mydirectory="$RET"
-			getcreds
-			echo PREPARE-SUCCESS
+			if [ -d "$mydirectory" ]; then
+				echo PREPARE-SUCCESS
+			else
+				echo PREPARE-FAILURE "$mydirectory not found"
+			fi
 		;;
 		TRANSFER)
 			key="$3"
-- 
cgit v1.2.3