From 6e60b08060a79182a6ae0180dbb7aefbc6011299 Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Sat, 8 Sep 2012 21:06:10 -0400
Subject: moved the PairStage inside the Verifiable data

---
 Assistant/WebApp/Configurators/Pairing.hs | 26 +++++++++++++-------------
 Assistant/WebApp/Types.hs                 |  2 +-
 Assistant/WebApp/routes                   |  2 +-
 3 files changed, 15 insertions(+), 15 deletions(-)

(limited to 'Assistant/WebApp')

diff --git a/Assistant/WebApp/Configurators/Pairing.hs b/Assistant/WebApp/Configurators/Pairing.hs
index 8b56f3392..ae94ddafb 100644
--- a/Assistant/WebApp/Configurators/Pairing.hs
+++ b/Assistant/WebApp/Configurators/Pairing.hs
@@ -58,8 +58,8 @@ getStartPairR = promptSecret Nothing $ \rawsecret secret -> do
 	username <- liftIO $ getUserName
 	reldir <- fromJust . relDir <$> lift getYesod
 	let sshkey = "" -- TODO generate/read ssh key
-	let mkmsg addr = PairReqM $ PairReq $
-		mkVerifiable (PairData hostname addr username reldir sshkey) secret
+	let mkmsg addr = PairMsg $ mkVerifiable
+		(PairReq, PairData hostname addr username reldir sshkey) secret
 	pip <- liftIO $ PairingInProgress secret <$> multicastPairMsg mkmsg
 	dstatus <- daemonStatus <$> lift getYesod
 	liftIO $ modifyDaemonStatus_ dstatus $
@@ -79,9 +79,9 @@ getInprogressPairR secret = bootstrap (Just Config) $ do
 getInprogressPairR _ = noPairing
 #endif
 
-getFinishPairR :: PairReq -> Handler RepHtml
+getFinishPairR :: PairMsg -> Handler RepHtml
 #ifdef WITH_PAIRING
-getFinishPairR req = promptSecret (Just req) $ \_ secret -> do
+getFinishPairR msg = promptSecret (Just msg) $ \_ secret -> do
 	error "TODO"
 #else
 getFinishPairR _ = noPairing
@@ -90,8 +90,8 @@ getFinishPairR _ = noPairing
 #ifdef WITH_PAIRING
 data InputSecret = InputSecret { secretText :: Maybe Text }
 
-promptSecret :: Maybe PairReq -> (Text -> Secret -> Widget) -> Handler RepHtml
-promptSecret req cont = bootstrap (Just Config) $ do
+promptSecret :: Maybe PairMsg -> (Text -> Secret -> Widget) -> Handler RepHtml
+promptSecret msg cont = bootstrap (Just Config) $ do
 	sideBarDisplay
 	setTitle "Pairing"
 	((result, form), enctype) <- lift $
@@ -101,25 +101,25 @@ promptSecret req cont = bootstrap (Just Config) $ do
                 FormSuccess v -> do
 			let rawsecret = fromMaybe "" $ secretText v
 			let secret = toSecret rawsecret
-			case req of
+			case msg of
 				Nothing -> case secretProblem secret of
 					Nothing -> cont rawsecret secret
 					Just problem ->
 						showform form enctype $ Just problem
-				Just r ->
-					if verified (fromPairReq r) secret
+				Just m ->
+					if verified (fromPairMsg m) secret
 						then cont rawsecret secret
 						else showform form enctype $ Just
 							"That's not the right secret phrase."
                 _ -> showform form enctype Nothing
         where
                 showform form enctype mproblem = do
-			let start = isNothing req
+			let start = isNothing msg
 			let badphrase = isJust mproblem
-			let msg = fromMaybe "" mproblem
+			let problem = fromMaybe "" mproblem
 			let (username, hostname) = maybe ("", "")
-				(\v -> (T.pack $ remoteUserName v, T.pack $ fromMaybe (showAddr $ remoteAddress v) (remoteHostName v)))
-				(verifiableVal . fromPairReq <$> req)
+				(\(_, v) -> (T.pack $ remoteUserName v, T.pack $ fromMaybe (showAddr $ remoteAddress v) (remoteHostName v)))
+				(verifiableVal . fromPairMsg <$> msg)
 			u <- T.pack <$> liftIO getUserName
 			let sameusername = username == u
                         let authtoken = webAppFormAuthToken
diff --git a/Assistant/WebApp/Types.hs b/Assistant/WebApp/Types.hs
index dd3bd4383..d018cddbf 100644
--- a/Assistant/WebApp/Types.hs
+++ b/Assistant/WebApp/Types.hs
@@ -93,6 +93,6 @@ instance PathPiece Transfer where
     toPathPiece = pack . show
     fromPathPiece = readish . unpack
 
-instance PathPiece PairReq where
+instance PathPiece PairMsg where
     toPathPiece = pack . show
     fromPathPiece = readish . unpack
diff --git a/Assistant/WebApp/routes b/Assistant/WebApp/routes
index 181b08f28..a266704b2 100644
--- a/Assistant/WebApp/routes
+++ b/Assistant/WebApp/routes
@@ -13,7 +13,7 @@
 /config/repository/add/rsync.net AddRsyncNetR GET
 /config/repository/pair/start StartPairR GET
 /config/repository/pair/inprogress/#Text InprogressPairR GET
-/config/repository/pair/finish/#PairReq FinishPairR GET
+/config/repository/pair/finish/#PairMsg FinishPairR GET
 
 /config/repository/first FirstRepositoryR GET
 
-- 
cgit v1.2.3